From 99e30437b7276246c151f6cf47497a317b11a959 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 31 Mar 2021 20:59:17 -0500 Subject: [PATCH 001/217] - Adds support for NSSL full 2-moment microphysics with droplets, rain, cloud ice, snow, graupel, and hail. Graupel and hail have predicted bulk density via the particle volume. Hail can be deactived. Simple CCN concentration can be predicted, either as the count of unactivated or activated nuclei. (Mansell et al. 2010, JAS) --- physics/GFS_MP_generic.F90 | 9 +- physics/GFS_MP_generic.meta | 16 + physics/GFS_PBL_generic.F90 | 116 +- physics/GFS_PBL_generic.meta | 128 + physics/GFS_rrtmg_pre.F90 | 34 +- physics/GFS_rrtmg_pre.meta | 16 + physics/GFS_rrtmgp_gfdlmp_pre.F90 | 2 +- physics/GFS_suite_interstitial.F90 | 92 +- physics/GFS_suite_interstitial.meta | 80 + physics/maximum_hourly_diagnostics.F90 | 25 +- physics/maximum_hourly_diagnostics.meta | 16 + physics/module_MYNNPBL_wrapper.F90 | 31 +- physics/module_MYNNPBL_wrapper.meta | 16 + physics/module_mp_nssl_2mom.F90 | 19729 ++++++++++++++++++++++ physics/mp_nsslg.F90 | 704 + physics/mp_nsslg.meta | 578 + 16 files changed, 21564 insertions(+), 28 deletions(-) create mode 100644 physics/module_mp_nssl_2mom.F90 create mode 100644 physics/mp_nsslg.F90 create mode 100644 physics/mp_nsslg.meta diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 6a8d3bfcb..588891b25 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -86,6 +86,7 @@ end subroutine GFS_MP_generic_post_init !> @{ subroutine GFS_MP_generic_post_run( & im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, con_g, rainmin, dtf, frain, rainc, & rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, 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, & @@ -101,6 +102,7 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires + integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm integer, intent(in) :: index_of_temperature,index_of_process_mp @@ -183,12 +185,12 @@ subroutine GFS_MP_generic_post_run( ice = ice0 snow = snow0 ! Do it right from the beginning for Thompson - else if (imp_physics == imp_physics_thompson) then + else if (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl2m & + .or. imp_physics == imp_physics_nssl2mccn) then tprcp = max (zero, rainc + frain * rain1) ! time-step convective and explicit precip graupel = frain*graupel0 ! time-step graupel ice = frain*ice0 ! time-step ice snow = frain*snow0 ! time-step snow - else if (imp_physics == imp_physics_fer_hires) then tprcp = max (zero, rain) ! time-step convective and explicit precip ice = frain*rain1*sr ! time-step ice @@ -264,7 +266,8 @@ subroutine GFS_MP_generic_post_run( !! and convective rainfall from the cumulus scheme if the surface temperature is below !! \f$0^oC\f$. - if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson) then + if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. & + imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn) then ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index a87cfe578..372cdf98c 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -240,6 +240,22 @@ type = integer intent = in optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [cal_pre] standard_name = flag_for_dominant_precipitation_type_partition long_name = flag controls precip type algorithm diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 63e622204..52f8cb63e 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -82,8 +82,10 @@ end subroutine GFS_PBL_generic_pre_finalize subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, & ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & + ntccn, nthl, nthnc, ntgv, nthv, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, ltaerosol, & + imp_physics_nssl2m,imp_physics_nssl2mccn, ltaerosol, nssl_hail_on, & hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) @@ -97,10 +99,13 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, integer, intent(in) :: im, levs, nvdiff, ntrac integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv logical, intent(in) :: trans_aero, ldiag3d, qdiag3d, lssav integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend + integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn + logical, intent(in) :: cplchm, ltaerosol, nssl_hail_on real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs @@ -250,6 +255,59 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, enddo enddo rtg_ozone_index = 3 + elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + ! nssl + IF ( nssl_hail_on ) THEN + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,nthl) + vdftra(i,k,8) = qgrs(i,k,ntlnc) + vdftra(i,k,9) = qgrs(i,k,ntinc) + vdftra(i,k,10) = qgrs(i,k,ntrnc) + vdftra(i,k,11) = qgrs(i,k,ntsnc) + vdftra(i,k,12) = qgrs(i,k,ntgnc) + vdftra(i,k,13) = qgrs(i,k,nthnc) + vdftra(i,k,14) = qgrs(i,k,ntgv) + vdftra(i,k,15) = qgrs(i,k,nthv) + vdftra(i,k,16) = qgrs(i,k,ntoz) + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + vdftra(i,k,17) = qgrs(i,k,ntccn) + ENDIF + enddo + enddo + + ELSE + ! no hail + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntlnc) + vdftra(i,k,8) = qgrs(i,k,ntinc) + vdftra(i,k,9) = qgrs(i,k,ntrnc) + vdftra(i,k,10) = qgrs(i,k,ntsnc) + vdftra(i,k,11) = qgrs(i,k,ntgnc) + vdftra(i,k,12) = qgrs(i,k,ntgv) + vdftra(i,k,13) = qgrs(i,k,ntoz) + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + vdftra(i,k,14) = qgrs(i,k,ntccn) + ENDIF + enddo + enddo + + ENDIF + + endif ! if (trans_aero) then @@ -326,10 +384,10 @@ end subroutine GFS_PBL_generic_post_finalize !! subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev,nqrimef, & - trans_aero, ntchs, ntchm, & + trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, imp_physics_mg, & - imp_physics_fer_hires, & - ltaerosol, cplflx, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, & + imp_physics_fer_hires, imp_physics_nssl2m, imp_physics_nssl2mccn, & + ltaerosol, nssl_hail_on, cplflx, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf,& shinhong, do_ysu, dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, & dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & index_of_process_pbl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, & @@ -349,6 +407,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires + integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn, nssl_hail_on logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu @@ -546,6 +605,57 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntoz) = dvdftra(i,k,3) enddo enddo + elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + ! nssl + IF ( nssl_hail_on ) THEN + do k=1,levs + do i=1,im + dqdt(i,k,ntqv) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntrw) = dvdftra(i,k,4) + dqdt(i,k,ntsw) = dvdftra(i,k,5) + dqdt(i,k,ntgl) = dvdftra(i,k,6) + dqdt(i,k,nthl) = dvdftra(i,k,7) + dqdt(i,k,ntlnc) = dvdftra(i,k,8) + dqdt(i,k,ntinc) = dvdftra(i,k,9) + dqdt(i,k,ntrnc) = dvdftra(i,k,10) + dqdt(i,k,ntsnc) = dvdftra(i,k,11) + dqdt(i,k,ntgnc) = dvdftra(i,k,12) + dqdt(i,k,nthnc) = dvdftra(i,k,13) + dqdt(i,k,ntgv) = dvdftra(i,k,14) + dqdt(i,k,nthv) = dvdftra(i,k,15) + dqdt(i,k,ntoz) = dvdftra(i,k,16) + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + dqdt(i,k,ntccn) = dvdftra(i,k,17) + ENDIF + enddo + enddo + + ELSE + + do k=1,levs + do i=1,im + dqdt(i,k,ntqv) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntrw) = dvdftra(i,k,4) + dqdt(i,k,ntsw) = dvdftra(i,k,5) + dqdt(i,k,ntgl) = dvdftra(i,k,6) + dqdt(i,k,ntlnc) = dvdftra(i,k,7) + dqdt(i,k,ntinc) = dvdftra(i,k,8) + dqdt(i,k,ntrnc) = dvdftra(i,k,9) + dqdt(i,k,ntsnc) = dvdftra(i,k,10) + dqdt(i,k,ntgnc) = dvdftra(i,k,11) + dqdt(i,k,ntgv) = dvdftra(i,k,12) + dqdt(i,k,ntoz) = dvdftra(i,k,13) + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + dqdt(i,k,ntccn) = dvdftra(i,k,14) + ENDIF + enddo + enddo + + ENDIF endif endif ! nvdiff == ntrac diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 59501e467..9a17b34b3 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -207,6 +207,46 @@ type = integer intent = in optional = F +[ntccn] + standard_name = index_for_cloud_condensation_nuclei_number_concentration + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthl] + standard_name = index_for_hail + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthnc] + standard_name = index_for_hail_number_concentration + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgv] + standard_name = index_for_graupel_volume + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthv] + standard_name = index_for_hail_volume + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -263,6 +303,22 @@ type = integer intent = in optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -271,6 +327,14 @@ type = logical intent = in optional = F +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [hybedmf] standard_name = flag_for_hybrid_edmf_pbl_scheme long_name = flag for hybrid edmf pbl scheme (moninedmf) @@ -628,6 +692,46 @@ type = integer intent = in optional = F +[ntccn] + standard_name = index_for_cloud_condensation_nuclei_number_concentration + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthl] + standard_name = index_for_hail + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthnc] + standard_name = index_for_hail_number_concentration + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgv] + standard_name = index_for_graupel_volume + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthv] + standard_name = index_for_hail_volume + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -684,6 +788,22 @@ type = integer intent = in optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -692,6 +812,14 @@ type = logical intent = in optional = F +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [cplflx] standard_name = flag_for_surface_flux_coupling long_name = flag controlling cplflx collection (default off) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index dbea66985..029c71637 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -20,6 +20,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & imp_physics_fer_hires, julian, yearlen, lndp_var_list, lsswr, lslwr, & @@ -93,6 +94,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, & imp_physics_mg, imp_physics_wsm6, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & imp_physics_fer_hires, & yearlen, icloud @@ -622,16 +624,21 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ccnd(i,k,4) = tracer1(i,k,ntsw) ! snow water enddo enddo - elseif (ncnd == 5) then ! GFDL MP, Thompson, MG3, FA + elseif ( ncnd == 5 .or. ncnd == 6) then ! GFDL MP, Thompson, MG3, NSSL do k=1,LMK do i=1,IM ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water ccnd(i,k,2) = tracer1(i,k,ntiw) ! ice water ccnd(i,k,3) = tracer1(i,k,ntrw) ! rain water + if (imp_physics == imp_physics_fer_hires ) then ccnd(i,k,4) = 0.0 else + IF ( ncnd == 5 ) THEN ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) ! snow + graupel + ELSEIF ( ncnd == 6 ) THEN + ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) + tracer1(i,k,nthl) ! snow + graupel + hail + ENDIF endif enddo enddo @@ -757,7 +764,24 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo endif - elseif (imp_physics == imp_physics_thompson) then ! Thompson MP + + elseif (imp_physics == imp_physics_nssl2m .or. & + imp_physics == imp_physics_nssl2mccn ) then ! NSSL MP + cldcov = 0.0 + if(effr_in) then + do k=1,lm + k1 = k + kd + do i=1,im + effrl(i,k1) = effrl_inout(i,k)! re_cloud (i,k) + effri(i,k1) = effri_inout(i,k)! re_ice (i,k) + effrr(i,k1) = 1000. ! rrain_def=1000. + effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) + enddo + enddo + endif + + elseif (imp_physics == imp_physics_thompson) then ! Thompson MP + ! ! Compute effective radii for QC, QI, QS with (GF, MYNN) or without (all others) sub-grid clouds ! @@ -1009,7 +1033,10 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & dzb, xlat_d, julian, yearlen, & clouds,cldsa,mtopa,mbota, de_lgth, alpha) ! --- outputs - elseif(imp_physics == imp_physics_thompson) then ! Thompson MP + elseif(imp_physics == imp_physics_thompson & + .or. imp_physics == imp_physics_nssl2m & + .or. imp_physics == imp_physics_nssl2mccn & + ) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv !-- MYNN PBL or convective GF @@ -1108,5 +1135,4 @@ end subroutine GFS_rrtmg_pre_run subroutine GFS_rrtmg_pre_finalize () end subroutine GFS_rrtmg_pre_finalize -!! @} end module GFS_rrtmg_pre diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 48ddc586d..5233f0064 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -257,6 +257,22 @@ type = integer intent = in optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 index ccbfd1df8..ba1910133 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.F90 +++ b/physics/GFS_rrtmgp_gfdlmp_pre.F90 @@ -107,7 +107,7 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld errflg = 0 ! Test inputs - if (ncnd .ne. 5) then + if (ncnd .ne. 5 .and. ncnd .ne. 6 ) then errmsg = 'Incorrect number of cloud condensates provided' errflg = 1 call check_error_msg('GFS_rrtmgp_gfdlmp_pre_run',errmsg) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 386164b8f..a9c2d8bc0 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -512,13 +512,15 @@ end subroutine GFS_suite_interstitial_3_finalize !> \section arg_table_GFS_suite_interstitial_3_run Argument Table !! \htmlinclude GFS_suite_interstitial_3_run.html !! - subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & + subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & + im, levs, nn, cscnv, & satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & xlon, xlat, gt0, gq0, imp_physics, imp_physics_mg, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, dtidx, ntlnc, & imp_physics_wsm6, imp_physics_fer_hires, prsi, ntinc, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & work1, work2, kpbl, kinver, ras, me, save_lnc, save_inc, & ldiag3d, qdiag3d, index_of_process_conv_trans, & @@ -529,9 +531,12 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & implicit none ! interface variables + logical, intent(in) :: otsptflag(1:ntracp1)! on/off switch for tracer transport + integer, intent(in) :: ntracp1 integer, intent(in ) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, ntsw,& ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, me, index_of_process_conv_trans + imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & + imp_physics_nssl2m, imp_physics_nssl2mccn ,me, index_of_process_conv_trans integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras @@ -576,9 +581,10 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & if (cscnv .or. satmedmf .or. trans_trac .or. ras) then tracers = 2 do n=2,ntrac - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & +! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & +! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + IF ( otsptflag(n) ) THEN tracers = tracers + 1 do k=1,levs do i=1,im @@ -662,6 +668,13 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & else save_qi(:,:) = clw(:,:,1) endif + else if (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! ice + clw(i,k,2) = gq0(i,k,ntcw) ! water + enddo + enddo elseif (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_mg .or. imp_physics == imp_physics_fer_hires) then do k=1,levs do i=1,im @@ -699,22 +712,28 @@ end subroutine GFS_suite_interstitial_4_finalize !! subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl2m,imp_physics_nssl2mccn, nssl_invertccn, otsptflag, ntracp1, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) use machine, only: kind_phys + use module_mp_nssl_2mom, only: qccn use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber + implicit none ! interface variables + logical, intent(in) :: otsptflag(1:ntracp1)! on/off switch for tracer transport by updraft and + integer, intent(in) :: ntracp1 integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl2m, imp_physics_nssl2mccn logical, intent(in) :: ltaerosol, convert_dry_rho + logical, intent(in) :: nssl_invertccn real(kind=kind_phys), intent(in ) :: con_pi, dtf real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc @@ -740,6 +759,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ! local variables real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys integer :: i,k,n,tracers,idtend + real(kind=kind_phys) :: liqm, icem, xccn, xcwmas, xccw, xcimas ! , qccn real(kind=kind_phys) :: rho, orho real(kind=kind_phys), dimension(im,levs) :: qv_mp !< kg kg-1 (dry mixing ratio) @@ -792,9 +812,14 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr tracers = 2 do n=2,ntrac ! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc ) then +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & +! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & +! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc & +! .and. & +! n /= nthl .and. n /= nthnc .and. n /= ntgv .and. & +! n /= nthv .and. n /= ntccn & +! ) then + IF ( otsptflag(n) ) THEN tracers = tracers + 1 if(n/=ntk .and. n/=ntlnc .and. n/=ntinc .and. n /= ntcw .and. n /= ntiw) then idtend=dtidx(100+n,index_of_process_conv_trans) @@ -827,6 +852,55 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo enddo + if ( .true. .and. ( imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) ) then + liqm = con_pi/6.*1.e3*(40.e-6)**3 ! 4./3.*con_pi*1.e-12 + icem = con_pi/6.*1.e3*(120.e-6)**3 ! 4./3.*con_pi*3.2768*1.e-14*890. + ! qccn = nssl_cccn/1.225 + do k=1,levs + do i=1,im + ! check number of available ccn + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_invertccn ) THEN + xccn = qccn - gq0(i,k,ntccn) + ELSE + xccn = gq0(i,k,ntccn) + ENDIF + ELSE + xccn = Max(0.0, qccn - gq0(i,k,ntlnc)) + ENDIF + + IF ( gq0(i,k,ntlnc) > 0.0 .and. save_qc(i,k) > 0.0 ) THEN + xcwmas = Max( liqm, clw(i,k,2)/gq0(i,k,ntlnc) ) + ELSE + xcwmas = liqm + ENDIF + + IF ( gq0(i,k,ntinc) > 0.0 .and. save_qi(i,k) > 0.0 ) THEN + xcimas = Max( liqm, clw(i,k,1)/gq0(i,k,ntinc) ) + ELSE + xcimas = icem + ENDIF + + IF ( xccn > 0.0 ) THEN + xccw = Min( xccn, max(0.0, (clw(i,k,2)-save_qc(i,k))) / xcwmas ) + gq0(i,k,ntlnc) = gq0(i,k,ntlnc) + xccw + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_invertccn ) THEN + ! ccn are activated CCN, so add + gq0(i,k,ntccn) = gq0(i,k,ntccn) + xccw + ELSE + ! ccn are unactivated CCN, so subtract + gq0(i,k,ntccn) = gq0(i,k,ntccn) - xccw + ENDIF + ENDIF + ENDIF + + gq0(i,k,ntinc) = gq0(i,k,ntinc) & + + max(0.0, (clw(i,k,1)-save_qi(i,k))) / xcimas + enddo + enddo + endif + if (imp_physics == imp_physics_thompson .and. (ntlnc>0 .or. ntinc>0)) then if_convert_dry_rho: if (convert_dry_rho) then do k=1,levs diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 2fef8390e..2b2299d65 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1167,6 +1167,22 @@ [ccpp-arg-table] name = GFS_suite_interstitial_3_run type = scheme +[otsptflag] + standard_name = flag_convective_tracer_transport_interstitial + long_name = flag for interstitial tracer transport + units = flag + dimensions = (number_of_tracers_plus_one) + type = logical + intent = in + optional = F +[ntracp1] + standard_name = number_of_tracers_plus_one + long_name = number of tracers plus one + units = count + dimensions = () + type = integer + intent = in + optional = F [im] standard_name = horizontal_loop_extent long_name = horizontal loop extent @@ -1411,6 +1427,22 @@ type = integer intent = in optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [prsi] standard_name = air_pressure_at_interface long_name = air pressure at model layer interfaces @@ -1807,6 +1839,14 @@ type = integer intent = in optional = F +[ntccn] + standard_name = index_for_cloud_condensation_nuclei_number_concentration + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -1855,6 +1895,30 @@ type = logical intent = in optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [dtf] standard_name = timestep_for_dynamics long_name = dynamics timestep @@ -2038,6 +2102,22 @@ type = integer intent = in optional = F +[otsptflag] + standard_name = flag_convective_tracer_transport_interstitial + long_name = flag for interstitial tracer transport + units = flag + dimensions = (number_of_tracers_plus_one) + type = logical + intent = in + optional = F +[ntracp1] + standard_name = number_of_tracers_plus_one + long_name = number of tracers plus one + units = count + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 1486ac027..10c9ab99e 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -27,7 +27,8 @@ end subroutine maximum_hourly_diagnostics_finalize #endif subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, & imp_physics_gfdl, imp_physics_thompson, & - imp_physics_fer_hires,con_g, phil, & + imp_physics_fer_hires, imp_physics_nssl2m, & + imp_physics_nssl2mccn, con_g, phil, & gt0, refl_10cm, refdmax, refdmax263k, u10m, v10m, & u10max, v10max, spd10max, pgr, t2m, q2m, t02max, & t02min, rh02max, rh02min, dtp, rain, pratemax, & @@ -36,7 +37,8 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, ! Interface variables integer, intent(in) :: im, levs logical, intent(in) :: reset, lradar - integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires + integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires, & + imp_physics_nssl2m, imp_physics_nssl2mccn real(kind_phys), intent(in ) :: con_g real(kind_phys), intent(in ) :: phil(:,:) real(kind_phys), intent(in ) :: gt0(:,:) @@ -73,15 +75,24 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, !Calculate hourly max 1-km agl and -10C reflectivity if (lradar .and. (imp_physics == imp_physics_gfdl .or. & imp_physics == imp_physics_thompson .or. & - imp_physics == imp_physics_fer_hires)) then + imp_physics == imp_physics_fer_hires .or. & + imp_physics == imp_physics_nssl2m .or. & + imp_physics == imp_physics_nssl2mccn)) then allocate(refd(im)) allocate(refd263k(im)) call max_fields(phil,refl_10cm,con_g,im,levs,refd,gt0,refd263k) if (reset) then - do i=1,im - refdmax(i) = -35. - refdmax263k(i) = -35. - enddo + IF ( imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) THEN + do i=1,im + refdmax(i) = 0. + refdmax263k(i) = 0. + enddo + ELSE + do i=1,im + refdmax(i) = -35. + refdmax263k(i) = -35. + enddo + ENDIF endif do i=1,im refdmax(i) = max(refdmax(i),refd(i)) diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 140c6390a..53988a164 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -71,6 +71,22 @@ type = integer intent = in optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 4b034f588..a117bb145 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -108,6 +108,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & + & imp_physics_nssl2m, imp_physics_nssl2mccn, & & ltaerosol, lprnt, errmsg, errflg ) ! should be moved to inside the mynn: @@ -210,7 +211,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_output, & & grav_settling, & & imp_physics, imp_physics_wsm6, & - & imp_physics_thompson, imp_physics_gfdl + & imp_physics_thompson, imp_physics_gfdl, & + & imp_physics_nssl2m, imp_physics_nssl2mccn !TENDENCY DIAGNOSTICS real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) @@ -398,6 +400,33 @@ SUBROUTINE mynnedmf_wrapper_run( & qnifa(i,k) = 0. enddo enddo + elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + ! NSSL + FLAG_QI = .true. + FLAG_QNI= .true. + FLAG_QC = .true. + FLAG_QNC= .true. + FLAG_QNWFA= .false. + FLAG_QNIFA= .false. + p_qc = 2 + p_qr = 0 + p_qi = 2 + p_qs = 0 + p_qg = 0 + p_qnc= 0 + p_qni= 0 + do k=1,levs + do i=1,im + sqv(i,k) = qgrs_water_vapor(i,k) + sqc(i,k) = qgrs_liquid_cloud(i,k) + sqi(i,k) = qgrs_ice_cloud(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) + qnwfa(i,k) = 0. + qnifa(i,k) = 0. + enddo + enddo elseif (imp_physics == imp_physics_thompson) then ! Thompson if(ltaerosol) then diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index e88975aff..2ff9f7f61 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1419,6 +1419,22 @@ type = integer intent = in optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 new file mode 100644 index 000000000..9b73797c4 --- /dev/null +++ b/physics/module_mp_nssl_2mom.F90 @@ -0,0 +1,19729 @@ +!WRF:MODEL_LAYER:PHYSICS + + +! prepocessed on "Oct 16 2020" at "14:58:00" + + + + + + + + +!--------------------------------------------------------------------- +! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: +! moist_adv_opt = 4, +! scalar_adv_opt = 4, (can also use option 3, which is WENO without the positive definite filter) +! The WENO-5 scheme provides a 5th-order (horizontal and vertical) adaptive weighting of components that +! better preserve monotinicity in strong gradients. The standard 5th-order formulation is prone to undershoots +! (negative values) of mass and number concentrations at cloud edges. The WENO scheme helps +! to prevent undershoots and results in less noise at cloud and reflectivity boundaries. This is particularly +! useful for multi-moment schemes to preserve relationships between mass and number concentration. An option is also available +! for WENO-5 advection of momentum, but this can result in excessive damping of poorly-resolved features. For both scalar and momentum +! the steps 1 and 2 of the Runge-Kutta time integration use standare 5th-order advection, and the WENO-5 is applied on the 3rd (final) +! RK step. Option 3 applies the WENO-5, and option 4 adds the positive definite filter (as also used in option 1). +! +! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; +! +! This module provides a 2-moment bulk microphysics scheme originally +! developed by Conrad Ziegler (Zeigler, 1985, JAS) and modified/upgraded in +! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation +! follows Mansell (2010, JAS), using parameter infall = 4. +! +! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) +! +! Average graupel particle density is predicted, which affects fall speed as well. +! Hail density prediction is by default disabled in this version, but may be enabled +! at some point if there is interest. +! +! Maintainer: Ted Mansell, National Severe Storms Laboratory +! +! Microphysics References: +! +! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small +! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. +! +! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and +! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, +! doi:10.1175/JAS-D-12-0264.1. +! +! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. +! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. +! +! Sedimentation reference: +! +! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. +! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. +! +! Possible parameters to adjust: +! +! ccn : base cloud condensation nuclei concentration (use namelist.input value "nssl_cccn") +! alphah, alphahl : Size distribution shape parameters for graupel (h) and hail (hl) +! infall : changes sedimentation options to see effects (see below) +! +! lightning model references: +! +! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The +! implementation of an explicit charging and discharge lightning scheme +! within the WRF-ARW model: Benchmark simulations of a continental squall line, a +! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 +! +! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated +! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287 +! +! Note: Some parameters below apply to unreleased features. +! +! +!--------------------------------------------------------------------- +! Sept. 2019: +! Bug fixes: +! - Effective radius calculation was only done at history times. Now every time step (though should be just before radiation is called) +! - Snow reflectivity: Previous "fix" was incorrect and yields snow dBZ that is too low. Reverted to old version which was correct +! - Incorrectly updated a state value in the reflectivity code. (Could cause small differences if reflectivity is not calculated) +! Updates: +! - Added code hints to use the "axtra2d" array to communicate rates from the microphysics routine into any 3d arrays that are passed in to the driver. +! - Graupel and hail drag coefficients are returned from fall speed subroutine to use in ventilation coeffs. for consistency (minor change) +! - Added (compile) option flag to turn on diagnosis of cloud droplet shape parameter based on number concentration +! - Added (compile) option flag icracr to turn off rain self-collection +! - Added compile options 'depfac' and 'meltfac' to adjust deposition/sublimation and melting (not freezing) rates of graupel/hail by a constant factor (for experimentation). Default value is 1.0 +! - Put limit on snow volume (2 cm) in aggregation rate +!--------------------------------------------------------------------- +! WRF 4.0 update: +! Major: +! Fixed excessive sublimation that could occur in very strong downdrafts (3.9.1.1 update) +! +! Minor: +! icefallopt=3 : New ice crystal fall speed that has faster speeds for small ice particles. Main effect +! is on anvil clouds to help them decay a bit faster. Old behavior can be recovered with icefallopt=1 +! Cosmetic: removed stray single quotes because some preprocessors complain about unclosed quotes even in comments +! +!--------------------------------------------------------------------- +! WRF 3.9.1.1 update: +! +! Added a check on overdepletion of ice by sublimation, which could sometimes result in water supersaturation +! Bug fix: setting of t7 used 'dn' instead of 'dn1' (Thanks to Chunxi Zhang) +! +!--------------------------------------------------------------------- +! WRF 3.9 updates: +! +! 2-moment scheme now creates number concentration tendencies from cumulus scheme mass mixing ratio rates +! Renamed internal gamma function routine from 'gamma' to 'gamma_sp' to avoid name conflicts +! Restored older settings that allow snow aggregation starting at T > -25C +! Adjusted Meyers number of activated nuclei by the local air density to compensate for using data at surface +! Minor updates to rain-ice crystal and hail-rain collection efficiencies +! +! +! Reduced minimum mean snow diameter from 100 microns to 10 microns +! +!--------------------------------------------------------------------- +! WRF 3.8 updates: +! Fixed issue with reflectivity conservation for graupel melting into rain. Rain number concentrations were too low, +! resulting in excessive reflectivity of a couple dBZ +! Changed default value of iusewetgraupel to 1 (turns off diagnostic meltwater on graupel for reflectivity) +! Apply a 70 m/s fall speed limit for sedimentation +! Changed vapor ice nucleation to Meyers-Ferrier method (original scheme) +! New method for Bigg freezing (ibiggopt=2) +! Reduced snow aggregration efficiency and restricted aggregation to higher temperatures (assuming dendrites and mechanical aggregation) +! Increased maximum graupel-droplet collection efficiency when hail is turned off (nssl_2momg) +! Updates for compatibility with WRF-NMM +! Added calculation of hail number concentration in calcnfromq (creates number concentration from mixing ratio +! when starting from an analysis). And fixed error in graupel intercept +! Bug fix in snow fall speeds +! Further fix in snow reflectivity +! Use diameter of maximum mass rather than mean diamter when checking maximum size +! Helped performance in sedimentation with flag "do_accurate_sedimentation" to control recalculation of fall speeds when +! more than one sub-time step is needed (often happens with large time steps and small dz near the ground): +! = .true. : recalculates fall speed after each substep (more accurate) +! = .false. : (default) reuses fall speeds calculated on the first substep (typical for most schemes), theoretically could cause an occasional glitch, but none seen in practice +! Increased maximum mean droplet radius from 40 to 60 microns, which alleviates spurious number concentration increases at low CCN concentration. +! Removed a duplicate factor from hail reflectivity that was causing a loss of about 6 dBZ (since WRF 3.5). +! +!--------------------------------------------------------------------- + + + +MODULE module_mp_nssl_2mom + + IMPLICIT NONE + + public nssl_2mom_driver + public nssl_2mom_init + public nssl_2mom_init_aero + private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis + private gamma_dp, gamxinfdp, gamma_dpr + private delbk, delabk + private gammadp + + logical, private :: cleardiag = .false. + PRIVATE + +#ifdef WRF_CHEM + integer, parameter :: wrfchem_flag = 1 +#else + integer, parameter :: wrfchem_flag = 0 +#endif + + LOGICAL, PRIVATE:: is_aerosol_aware = .false. +! From ThompsonAero: +! Declaration of constants for assumed CCN/IN aerosols when none in +! the input data. Look inside the init routine for modifications +! due to surface land-sea points or vegetation characteristics. + REAL, PARAMETER, PRIVATE:: naIN0 = 1.5E6 + REAL, PARAMETER, PRIVATE:: naIN1 = 0.5E6 + REAL, PARAMETER, PRIVATE:: naCCN0 = 300.0E6 + REAL, PARAMETER, PRIVATE:: naCCN1 = 50.0E6 + + logical, private :: turn_on_cin = .false. + + integer, private :: eqtset = 1 ! Flag for use with cm1 to use alternate equation set (changes latent heating rates) + ! value of > 2 invokes the equivalent version of eqtset=2 that applies updates to both theta and Pi. + double precision, parameter, public :: zscale = 1.0d0 ! 1.000e-10 + double precision, parameter, public :: zscaleinv = 1.0d0/zscale ! 1.000e-10 + + + real, parameter :: warmonly = 0.0 ! testing parameter, set to 1.0 to reduce to warm-rain physics (ice variables stay zero) + + logical, parameter :: lwsm6 = .false. ! act like wsm6 for some single moment interactions + +! some constants from WSM6 + real, parameter :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter + real, parameter :: roqimax = 2.08e22*dimax**8 + +! Params for dbz: + integer :: iuseferrier = 1 ! =1: use dry graupel only from Ferrier 1994; = 0: Use Smith (wet graupel) + integer :: idbzci = 1 + integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + ! =2 turn on for graupel density less than 300. only + integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + integer :: iusewetsnow = 1 ! =1 to turn on diagnosed bright band + +! microphysics + + real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params + real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params + real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params + real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params + + real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel) + real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail) + + real :: cnohmn = 1.e-2 ! minimum intercept for 2-moment graupel (alphah < 0.5) + real :: cnohlmn = 1.e-2 ! minimum intercept for 2-moment hail (alphahl < 0.5) + +! Autoconversion parameters + + real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5) + real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion) + real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) + real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value + real , public :: qccn ! ccn "mixing ratio" + integer, private :: iauttim = 1 ! 10-ice rain delay flag + real , private :: auttim = 300. ! 10-ice rain delay time + real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual + +!#if (NMM_CORE == 1) +! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true +! logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state +!#else + logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state +!#endif + logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) + real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) + + +! sedimentation flags +! itfall -> 0 = 1st order fallout (other options removed) +! iscfall, infall -> fallout options for charge and number concentration, respectively +! 1 = mass-weighted fall speed; 2 = number-weighted fallspeed. + integer, private :: itfall = 0 + integer, private :: iscfall = 1 + integer, private :: irfall = -1 + logical, private :: do_accurate_sedimentation = .false. ! if true, recalculate fall speeds on sub time steps; (more expensive) + ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) + ! Mainly is an issue for small dz near the surface. + integer, private :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) + ! 1 -> uses mass-weighted fallspeed for N ALWAYS + ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS) + ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) + ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) + ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. + real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) + real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed + real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed + real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed + real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed + integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) + integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4) + real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4) + real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4) + real , private :: cdhldnmin = 500., cdhldnmax = 800.0 ! defaults for hail (icdx=4) + real , private :: vtmaxsed = 70. ! Limit on fall speed (m/s, all moments) for sedimentation calculations. Not applied to fall speeds for microphysical rates + + integer :: rssflg = 1 ! Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value + integer :: sssflg = 1 ! As above but for snow + integer :: hssflg = 1 ! As above but for graupel + integer :: hlssflg = 1 ! As above but for hail + +! input flags + + integer, private :: ndebug = -1, ncdebug = 0 + integer, private :: ipconc = 5 + integer, private :: ichaff = 0 + integer, parameter :: ilimit = 0 + + real, private :: constccw = -1. + + real, private :: cimn = 1.0e3, cimx = 1.0e6 + + + real , private :: ifrzg = 1.0 ! fraction of frozen drops (Bigg freezing) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail + real , private :: ifiacrg = 1.0 ! fraction of frozen drops (3-component freezing qiacr) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail + real , private :: ifrzs = 1.0 ! fraction of small frozen drops going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + real , private :: ffrzs = 0.0 ! fraction of other initiated cloud ice going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget) + integer, private :: irimtim = 0 ! future use +! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds + + integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993) + real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985) + real , private :: rimc3 = 170.0 ! minimum rime density + real :: rimc4 = 900.0 ! maximum rime density + real , private :: rimtim = 120.0 ! cut-off rime time (10ICE) + real , private :: eqtot = 1.0e-9 ! threshold for mass budget reporting + real, private :: rimdenvwgt = 0.0 ! weight (0-1) given to number-weighted fall speed when calculating rime density + + integer, private :: ireadmic = 0 + + integer, private :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data + integer, private :: iccwflg = 1 ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid) + ! (first nucleation is done with a KW sat. adj. step) + integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field + integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) + integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud + ! =2 renucleation following Twomey/Cohard&Pinty + ! =7 New renucleation that requires prediction of the number of activated nuclei + ! i.e., not only at cloud base + integer, private :: irenuc3d = 0 ! =1 to include horizontal gradient in renucleation of droplets within the cloud + real :: renucfrac = 0.0 ! = 0 : cnuc = cwccn + ! = 1 : cnuc = actual available CCN + ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac + real :: ssf2kmax = 1.05 ! max value for ssf**cck in irenuc=4 + real , private :: cck = 0.6 ! exponent in Twomey expression + real , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation + + real , private :: cwccn ! , cwmasn,cwmasx + real , private :: ccwmx + + integer, private :: idocw = 1, idorw = 1, idoci = 1, idoir = 1, idoip = 1, idosw = 1 + integer, private :: idogl = 1, idogm = 1, idogh = 1, idofw = 1, idohw = 1, idohl = 1 +! integer, private :: ido(3:14) = / 12*1 / + + +! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr + integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process + integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010) + real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott + integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version + integer, private :: ihrn = 0 ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only) + integer, private :: ibfc = 1 ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on) + real, private :: cwfrz2snowfrac = 0.0 ! fraction of freezing droplet mass to send to snow + real, private :: cwfrz2snowratio = 5. ! Assumed number of frozen droplets in a cluster + integer, private :: iremoveqwfrz = 1 ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation + integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals + ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron) + integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off) + integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel + ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation) + integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) + integer :: ibiggsmallrain = 0 ! 1 = When rain is too small, freeze none to graupel and send all to snow (experimental) + integer, private :: iacrsize = 5 ! assumed min size of drops freezing by capture + ! 1: > 500 micron diam + ! 2: > 300 micron + ! 3: > 40 micron + ! 4: all sizes + ! 5: > 150 micron (only for imurain = 1) + real , private :: cimas0 = 6.62e-11 ! default mass of Hallett-Mossop crystals + ! 6.62e-11kg results in half the diam. (60 microns) of old default value of 5.0e-10 + real , private :: cimas1 = 6.88e-13 ! default mass of new ice crystals + real , private :: splintermass = 6.88e-13 + real , private :: cfnfac = 0.1 ! Hack factor that goes with icfn=1 + integer, private :: iscni = 4 ! default option for ice crystal aggregation/conversion to snow + real , private :: fscni = 1.0 ! factor for calculating cscni + logical, private :: imeyers5 = .false. ! .false.=off, true=on for Meyers ice nucleation for temp > -5 C + real , private :: dmincw = 15.0e-6 ! minimum droplet diameter for collection for iehw=3 + integer, private :: iehw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data + integer, private :: iehlw = 1 ! 0 -> ehlw=ehlw0; 1 -> old ehlw; 2 -> test ehlw with Mason table data + ! For ehw/ehlw = 1, ehw0/ehlw0 act as maximum limit on collection efficiency (defaults are 1.0) + integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) + integer, private :: iehr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + integer, private :: iehlr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + real , private :: ehw0 = 0.9 ! constant or max assumed graupel-droplet collection efficiency + real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency + real , private :: ehlw0 = 0.9 ! constant or max assumed hail-droplet collection efficiency + real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency + real :: ehlr0 = 1.0 ! constant or max assumed hail-rain collection efficiency + real , private :: exwmindiam = 0.0 ! minimum diameter of droplets for riming. If set > 0, will exclude that fraction of mass/number from accretion (idea from Furtado and Field 2017 JAS but also Fierro and Mansell 2017) + + + real , private :: esilfo0 = 1.0 ! factor for LFO collection efficiency of snow for cloud ice. + real , private :: ehslfo0 = 1.0 ! factor for LFO collection efficiency of hail/graupel for snow. + + integer, private :: ircnw = 5 ! single-moment warm-rain autoconversion option. 5= Ferrier 1994. + real , private :: qminrncw = 2.0e-3 ! qc threshold for rain autoconversion (NA for ircnw=5) + + integer, private :: iqcinit = 2 ! For ZVDxx schemes, flag to choose which way to initialize droplets + ! 1 = Soong-Ogura adjustment + ! 2 = Saturation adjustment to value of ssmxinit + ! 3 = KW adjustment + + real , private :: ssmxinit = 0.4 ! saturation percentage to adjust down to for initial cloud + ! formation (ZVDxx scheme only) + + real , private :: ewfac = 1.0 ! hack factor applied to graupel and hail collection eff. for droplets + real , private :: eii0 = 0.1 ,eii1 = 0.1 ! graupel-crystal coll. eff. parameters: eii0*exp(eii1*min(temcg(mgs),0.0)) + ! set eii1 = 0 to get a constant value of eii0 + real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) + ! set eii1hl = 0 to get a constant value of eii0hl + real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals + real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain + real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency + real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) + ! set ehs1 = 0 to get a constant value of ehs0 + real , private :: ess0 = 1.0, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) + ! set ess1 = 0 to get a constant value of ess0 + real , private :: esstem1 = -25. ! lower temperature where snow aggregation turns on + real , private :: esstem2 = -20. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + real , private :: essrmax = 0.02 ! maximum snow radius (meters) for csacs + real , private :: essfrac1 = 0.5 ! snow mass fraction 1 for aggregation roll-off + real , private :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off + integer, private :: iessec0flag = 0 ! flag to activate aggregation roll-off + real , private :: ehsfrac = 1.0 ! multiplier for graupel collection efficiency in wet growth + real , private :: ehimin = 0.0 ! Minimum collection efficiency (graupel - ice crystal) + real , private :: ehimax = 1.0 ! Maximum collection efficiency (graupel - ice crystal) + real , private :: ehsmax = 0.5 ! Maximum collection efficiency (graupel - snow) + real , private :: ecollmx = 0.5 ! Maximum collision efficiency for graup/hail with ice; used only for charging rates + integer, private :: iglcnvi = 1 ! flag for riming conversion from cloud ice to rimed ice/graupel + integer, private :: iglcnvs = 2 ! flag for conversion from snow to rimed ice/graupel + + real , private :: rz ! reflectivity conservation factor for graupel/rain + ! now calculated in icezvd_dr.F from alphah and rnu + ! currently only used for graupel melting to rain + real , private :: rzhl ! reflectivity conservation factor for hail/rain + ! now calculated in icezvd_dr.F from alphahl and rnu + + real , private :: rzs ! reflectivity conservation factor for snow(imusnow=3) with rain (imurain=1) + + real , private :: alphahacx = 0.0 ! assumed minimum shape parameter for zhacw and zhacr + + real , private :: fconv = 1.0 ! factor to boost max graupel depletion by riming conversions in 10ICE + + real , private :: rg0 = 400.0 ! reference graupel density for graupel fall speed + + integer, private :: rcond = 2 ! (Z only) rcond = 2 includes rain condensation in loop with droplet condensation + ! 0 = no condensation on rain; 1 = bulk condensation on rain + integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation + ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.) + + real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 + ! and for ciacrf for iacr=4 + real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail + real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail + + integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail + integer, private :: imltshddmr = 2 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail + ! and max mean diameter of rain) + ! 1=new method where mean diameter of rain during melting is adjusted linearly downward + ! toward 3 mm for large (> sheddiam) graupel and hail, to take into account shedding of + ! smaller drops. sheddiam0 controls the size of graupel/hail above which the assumed + ! mean diameter of rain is set to 3 mm + ! Only valid for ihmlt = 2 for ZVD(H) but also applies to ZVD(H)M + ! 2 = method that sets the resulting rain size ( vshdgs ) according to the mass-weighted diameter of the ice + + real :: mltdiam1 = 9.0e-3, mltdiam2 = 16.0e-3, mltdiam3 = 19.0e-3, mltdiam4 = 200.0e-3, mltdiam05 = 4.5e-3 + + integer, private :: nsplinter = 0 ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle + real, private :: lawson_splinter_fac = 2.5e-11 ! constant in Lawson et al. (2015, JAS) for ice particle production from freezing drops + integer, private :: isnwfrac = 0 ! 0= no snow fragmentation; 1 = turn on snow fragmentation (Schuur, 2000) + +! integer, private :: denscale = 1 ! 1=scale num. conc. and charge by air density for advection, 0=turn off for comparison + + real, private :: qhdpvdn = -1. + real, private :: qhacidn = -1. + + logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel + integer, private :: imixedphase = 0 + logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density + logical, private :: qhdenmod = .false. ! true = modify graupel density by linear interpolation of graupel and rain density + logical, private :: qsvtmod = .false. ! true = modify snow fall speed by linear interpolation of snow and rain vt + real , private :: sheddiam = 8.0e-03 ! minimum diameter of graupel before shedding occurs + real :: sheddiamlg = 10.0e-03 ! diameter of hail to use fwmlarge + real :: sheddiam0 = 20.0e-03 ! diameter of hail at which all water is shed + + integer :: ifwmhopt = 2 ! option for calculating maximum liquid fraction when fwmh and/or fwmhl is set to -1 + ! 1 = maximum based on size of maximum mass diameter + ! 2 = integrate over spectrum for maximum liquid (experimental) + + integer :: ihxw2rain = 0 ! = 0 no transfer + ! = 1 transfer completely melted (99.5%) graupel/hail to rain when fwmh/fwmhl is set to -1. + + real , private :: fwms = 0.5 ! maximum liquid water fraction on snow + real , private :: fwmh = 0.5 ! maximum liquid water fraction on graupel + real , private :: fwmhl = 0.5 ! maximum liquid water fraction on hail + real :: fwmlarge = 0.2 ! maximum liquid water fraction on hail larger than sheddiam + integer :: ifwmfall = 0 ! whether to interpolate toward rain fall speed for graupel and hail + ! when diam < sheddiam and liquid fraction is predicted (0=no, 1=yes) + + logical :: rescale_high_alpha = .false. ! whether to rescale number. conc. when alpha = alphamax (3-moment only) + logical :: rescale_low_alpha = .true. ! whether to rescale Z (graupel/hail) when alpha = alphamin (3-moment only) + logical :: rescale_low_alphar = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphah = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphahl = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + + real, parameter :: alpharmax = 8. ! limited for rwvent calculation + + integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use + ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter + ! 2 = Straka and Mansell (2005) conversion using size threshold + real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. + real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) + real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on) + real , private :: dwmin = 0.0 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail + real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) + real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed + + integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. + integer, private :: imusnow = 3 ! 3 for gamma-volume, 1 for gamma-diameter DSD for snow (=1 NOT IMPLEMENTED!!). + integer, private :: iturbenhance = 0 ! warm-rain collision enhancement + ! 1 = enhance autoconversion only + ! 2 = add rain collection of cloud + ! 3 = add rain self-collection + integer, private :: isedonly = 0 ! 1= only do sedimentation and skip other microphysics + integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1) + integer, private :: izwisventr = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3) + integer :: iresetmoments = 0 ! if >0, then set all moments to zero when one of them is zero (3-moment only) + integer, private :: imaxdiaopt = 3 + ! = 1 use mean diameter for breakup + ! = 2 use maximum mass diameter for breakup + ! = 3 use mass-weighted diameter for breakup + integer, private :: dmrauto = 0 + ! = -1 no limiter on crcnw + ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) + ! = 1 DTD version based on MY code + ! = 2 DTD mass-weighted version based on MY code + ! = 3 Milbrandt version (from Cohard and Pinty code + integer :: dmropt = 0 ! extra option for crcnw + integer :: dmhlopt = 1 ! options for graupel -> conversion + integer :: irescalerainopt = 3 ! 0 = default option + ! 1 = qx(mgs,lc) > qxmin(lc) + ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 + ! 3 = temcg(mgs) > 0.0.and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 + real :: rescale_wthresh = 3.0 + real :: rescale_tempthresh = 0.0 + real, parameter :: alpharaut = 0.0 ! MY2005 for autoconversion + real :: cxmin = 1.e-8 ! threshold cutoff for number concentration + real :: zxmin = 1.e-28 ! threshold cutoff for reflectivity moment + + integer :: ithompsoncnoh = 0 ! For single moment graupel only + ! 0 = fixed intercept + ! 1 = intercept based on graupel mass + + integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting + ! when liquid fraction is not predicted + integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories + integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters + ! 1 = original Zrnic et al. (Mansell et al. 2010) + ! 2 = Ferrier 1994 (results in slower fall speeds) + + integer, private :: isnowdens = 1 ! Option for choosing between snow density options + ! 1 = constant of 100 kg m^-3 + ! 2 = Option based on Cox + + integer, private :: ibiggsnow = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing + ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction + ! 3 = switch conversion over to snow for small frozen drops from both + + integer, private :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi) + + real, private :: takshedsize1 = 0.15 ! diameter (cm) of drop shed from ice with D > 1.9 cm + real, private :: takshedsize2 = 0.3 ! diameter (cm) of drop shed from ice with D < 1.9 cm and D > 0.8 cm + real, private :: takshedsize3 = 0.45 ! diameter (cm) of drop shed from ice with D < 1.6 cm and D > 0.8 cm + integer, private :: numshedregimes = 3 + + real, private :: evapfac = 1.0 ! Multiplier on rain evaporation rate + real, private :: depfac = 1.0 ! Multiplier on graupel/hail deposition/sublimation rate + real,private,parameter :: meltfac = 1.0 ! Multiplier on graupel/hail melting rate + + integer, private :: ibinhmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of graupel, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + integer, private :: ibinhlmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of hail, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1) + integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr + integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr + real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr + real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting + real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow. + real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter + + integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau) + + integer :: imaxsupopt = 4 ! how to treat saturation adjustment in two-moment droplets + ! 1 = add droplets with same mean mass as current droplets + ! 2 = add droplets with minimum radius of 30 microns + ! 3 = only add 1.5*cxmin to number concentration (allow max size to apply) + ! 4 = add droplets with minimum radius of 20 microns + real :: maxsupersat = 1.9 ! maximum supersaturation ratio, above which a saturation adustment is done + real :: ssmxuf = 4.0 ! supersaturation at which to start using "ultrafine" CCN (if ccnuf > 0.) + + + integer, parameter :: icespheres = 0 ! turn ice spheres (frozen droplets) on (1) or off (0). NOT COMPLETE IN WRF/ARPS/CM1 CODE! + integer, parameter :: lqmx = 30 + integer, parameter :: lt = 1 + integer, parameter :: lv = 2 + integer, parameter :: lc = 3 + integer, parameter :: lr = 4 + integer, parameter :: li = 5 + integer, private :: lis = 0 + integer, private :: ls = 6 + integer, private :: lh = 7 + integer, private :: lhl = 0 + + integer, private :: lccn = 9 ! 0 or 9, other indices adjusted accordingly + integer, private :: lccnuf = 0 + integer, private :: lccna = 0 + integer, private :: lcina = 0 + integer, private :: lcin = 0 + integer, private :: lnc = 9 + integer, private :: lnr = 10 + integer, private :: lni = 11 + integer, private :: lnis = 0 + integer, private :: lns = 12 + integer, private :: lnh = 13 + integer, private :: lnhl = 0 + integer, private :: lss = 0 + integer :: lvh = 15 + + integer, private :: lhab = 8 + integer, private :: lg = 7 + +! Particle volume + + integer :: lvi = 0 + integer :: lvs = 0 + integer :: lvgl = 0 + integer :: lvgm = 0 + integer :: lvgh = 0 + integer :: lvf = 0 +! integer :: lvh = 16 + integer :: lvhl = 0 + +! liquid water fraction (not predicted here but tested for) + integer :: lhw = 0 + integer :: lsw = 0 + integer :: lhlw = 0 + integer :: lhwlg = 0 + integer :: lhlwlg = 0 + +! reflectivity (6th moment) ! not predicted here but may be tested against + + integer :: lzr = 0 + integer :: lzi = 0 + integer :: lzs = 0 + integer :: lzgl = 0 + integer :: lzgm = 0 + integer :: lzgh = 0 + integer :: lzf = 0 + integer :: lzh = 0 + integer :: lzhl = 0 + +! Space charge + + integer :: lscw = 0 + integer :: lscr = 0 + integer :: lsci = 0 + integer :: lscis = 0 + integer :: lscs = 0 + integer :: lsch = 0 + integer :: lschl = 0 + integer :: lscwi = 0 + integer :: lscpi = 0 + integer :: lscni = 0 + integer :: lscpli = 0 + integer :: lscnli = 0 + integer :: lschab = 0 + + integer :: lscb = 0 + integer :: lsce = 0 + integer :: lsceq = 0 + +! integer, parameter :: lscmx = 100 + + integer :: lne = 0 ! last varible for transforming + + real :: cnoh0 = 4.0e+5 + real :: hwdn1 = 700.0 + + real :: alphai = 0.0 ! shape parameter for ZIEG ice crystals ! not currently used + real :: alphas = 0.0 ! shape parameter for ZIEG snow ! used only for single moment + real :: alphar = 0.0 ! shape parameter for rain (imurain=1 only) + real, private :: alphah = 0.0 ! set in namelist!! shape parameter for ZIEG graupel + real, private :: alphahl = 1.0 ! set in namelist!! shape parameter for ZIEG hail + + real :: dmuh = 1.0 ! power in exponential part (graupel) + real :: dmuhl = 1.0 ! power in exponential part (hail) + + real, private :: alphamax = 15. + real, private :: alphamin = 0. + real, parameter :: rnumin = -0.8 + real, parameter :: rnumax = 15.0 + + + real :: cnu = 0.0 ! default value of droplet shape parameter. Can be diagnosed by setting idiagnosecnu=1 + real, parameter :: rnu = -0.8, snu = -0.8, cinu = 0.0 +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + + real xnu(lc:lqmx) ! 1st shape parameter (mass) + real xmu(lc:lqmx) ! 2nd shape parameter (mass) + real dnu(lc:lqmx) ! 1st shape parameter (diameter) + real dmu(lc:lqmx) ! 2nd shape parameter (diameter) + + real ax(lc:lqmx) + real bx(lc:lqmx) + real fx(lc:lqmx) + + real da0 (lc:lqmx) ! collection coefficients from Seifert 2005 + real dab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real dab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real da1 (lc:lqmx) ! collection coefficients from Seifert 2005 + real bb (lc:lqmx) + +! put ipelec here for now.... + integer :: ipelec = 0 + integer :: isaund = 0 + logical :: idoniconly = .false. + integer, private :: elec_on_time = -1 ! time (seconds) to turn on charge separation. + integer, private :: elec_ramp_time = 0 ! time (interval) for linear ramp after elec_on_time + ! (i.e., linear factor on chg sep to smoothly turn on elec) + ! full charging rate is achieved at time = elec_on_time + elec_ramp_time + integer :: jchgs = 3 ! number of points near boundary where charging is turned off (to keep lightning from getting wonky) + integer :: jchgn = 2 + integer :: ichge = 3 + integer :: ichgw = 2 + real :: charging_border = 4000. ! width of no-charging zone from boundary + real, private :: delqnw = -1.0e-10!-1.0e-12 ! + real, private :: delqxw = 1.0e-10! 1.0e-12 ! + real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed + +! +! gamma function lookup table +! + integer ngm0,ngm1,ngm2 + parameter (ngm0=3001,ngm1=500,ngm2=500) + double precision, parameter :: dgam = 0.01, dgami = 100. + double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) + + integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15 + integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25 +! real, parameter :: maxratiolu = 25. + real, parameter :: maxratiolu = 100. ! 25. + real, parameter :: maxalphalu = 15. + real, parameter :: minalphalu = -0.95 + real, parameter :: dqiacralpha = maxalphalu/Float(nqiacralpha), dqiacrratio = maxratiolu/Float(nqiacrratio) + real, parameter :: dqiacrratioinv = 1./dqiacrratio, dqiacralphainv = 1./dqiacralpha + integer, parameter :: ialpstart = minalphalu*dqiacralphainv + real :: ciacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + real :: qiacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + real :: ziacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) +! real :: ciacrratio(0:nqiacrratio,0:nqiacralpha) +! real :: qiacrratio(0:nqiacrratio,0:nqiacralpha) +! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) +! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) + + integer, parameter :: ngdnmm = 9 + real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail + + DATA mmgraupvt(:,1) / 50., 150., 250., 350., 450., 550., 650., 750., 850./ + DATA mmgraupvt(:,2) / 62.923, 94.122, 114.74, 131.21, 145.26, 157.71, 168.98, 179.36, 189.02 / + DATA mmgraupvt(:,3) / 0.67819, 0.63789, 0.62197, 0.61240, 0.60572, 0.60066, 0.59663, 0.59330, 0.59048 / + + integer lsc(lc:lqmx) + integer ln(lc:lqmx) + integer ipc(lc:lqmx) + integer lvol(lc:lqmx) + integer lz(lc:lqmx) + integer lliq(li:lqmx) + integer denscale(lc:lqmx) ! flag for density scaling (mixing ratio conversion) + + integer ido(lc:lqmx) + logical ldovol + + real xdn0(lc:lqmx) + real xdnmx(lc:lqmx), xdnmn(lc:lqmx) + real cdx(lc:lqmx) + real cno(lc:lqmx) + real xvmn(lc:lqmx), xvmx(lc:lqmx) + real qxmin(lc:lqmx) + + integer nqsat + parameter (nqsat=1000001) ! (nqsat=20001) + real fqsat,fqsati + parameter (fqsat=0.002,fqsati=1./fqsat) + real tabqvs(nqsat),tabqis(nqsat),dtabqvs(nqsat),dtabqis(nqsat) + +! +! constants +! + real, parameter :: cp608 = 0.608 ! constant used in conversion of T to Tv + real, parameter :: ar = 841.99666 ! rain terminal velocity power law coefficient (LFO) + real, parameter :: br = 0.8 ! rain terminal velocity power law coefficient (LFO) + real, parameter :: aradcw = -0.27544 ! + real, parameter :: bradcw = 0.26249e+06 ! + real, parameter :: cradcw = -1.8896e+10 ! + real, parameter :: dradcw = 4.4626e+14 ! + real, parameter :: bta1 = 0.6 ! beta-1 constant used for ice nucleation by deposition (Ferrier 94, among others) + real, parameter :: cnit = 1.0e-02 ! No for ice nucleation by deposition (Cotton et al. 86) + real, parameter :: dragh = 0.60 ! coefficient used to adjust fall speed for hail versus graupel (Pruppacher and Klett 78) + real, parameter :: dnz00 = 1.225 ! reference/MSL air density + real, parameter :: rho00 = 1.225 ! reference/MSL air density +! cs = 4.83607122 ! snow terminal velocity power law coefficient (LFO) +! ds = 0.25 ! snow terminal velocity power law coefficient (LFO) +! new values for cs and ds + real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient + real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient + real, parameter :: pi = 3.141592653589793 + real, parameter :: piinv = 1./pi + real, parameter :: pid4 = pi/4.0 + + real, parameter :: gr = 9.8 + +! +! max and min mean volumes +! + real xvrmn, xvrmx0 ! min, max rain volumes + real xvsmn, xvsmx ! min, max snow volumes + real xvfmn, xvfmx ! min, max frozen drop volumes + real xvgmn, xvgmx ! min, max graupel volumes + real xvhmn, xvhmn0, xvhmx, xvhmx0 ! min, max hail volumes + real xvhlmn, xvhlmx ! min, max lg hail volumes + + real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3 + real, parameter :: dhmn0 = 0.3e-3 + real, private :: dhmn = dhmn0, dhmx = -1. + + real, parameter :: cwradn = 2.5e-7, xcradmn = cwradn ! minimum radius + real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius + real, parameter :: cwc1 = 6.0/(pi*1000.) + +! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius + real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius + real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius + real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13 + + real, parameter :: xvimn=0.523599*(2.*5.e-6)**3 ! mks min volume = 5 micron radius + real, parameter :: xvimx=0.523599*(2.*1.e-3)**3 ! mks max volume = 1 mm radius (solid sphere approx) + + real, private :: xvdmx = -1.0 ! 3.0e-3 + real :: xvrmx + parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvsmn=0.523599*(0.01e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 ) ! mks xvfmx = (pi/6)*(20mm)**3 + parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx=0.523599*(dhlmx)**3 ) ! mks xvfmx = (pi/6)*(40mm)**3 + +! +! electrical permitivity of air C / (N m**2) - check the units +! + real eperao + parameter (eperao = 8.8592e-12 ) + + real ec,eci ! fundamental unit of charge + parameter (ec = 1.602e-19) + parameter (eci = 1.0/ec) + + real :: scwppmx = 20.0e-12 + real :: scippmx = 20.0e-12 +! +! constants +! + real, parameter :: c1f3 = 1.0/3.0 + + real, parameter :: cai = 21.87455 + real, parameter :: caw = 17.2693882 + real, parameter :: cbi = 7.66 + real, parameter :: cbw = 35.86 + + real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation + real, parameter :: cawbolton = 17.67 + + real, parameter :: tfr = 273.15, tfrh = 233.15 + + real, parameter :: cp = 1004.0, rd = 287.04 + real, parameter :: cpi = 1./cp + real, parameter :: cap = rd/cp, poo = 1.0e+05 + + real, parameter :: rw = 461.5 ! gas const. for water vapor + real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) + real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc + real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity + real, parameter :: tfrcbw = tfr - cbw + real, parameter :: tfrcbi = tfr - cbi + + ! GHB: Needed for eqtset=2 in cm1 +! REAL, PRIVATE :: cv = cp - rd + real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air + REAL, PRIVATE, parameter :: cvv = 1408.5 + REAL, PRIVATE, parameter :: cpl = 4190.0 + REAL, PRIVATE, parameter :: cpigb = 2106.0 + ! GHB + + real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) + real :: ventr, ventrn, ventc, c1sw + + + real :: cckm,ccne,ccnefac,cnexp,CCNE0 + + integer :: na = 9 + integer :: nxtra = 1 + real gf4p5, gf4ds, gf4br + real gsnow1, gsnow53, gsnow73 + real gfcinu1, gfcinu1p47, gfcinu2p47 + real gfcinu1p22,gfcinu2p22 + real gfcinu1p18,gfcinu2p18 + + real :: cwchtmp0 = 1.0 + real :: cwchltmp0 = 1.0 + + real :: esctot = 1.0e-13 + + integer iexy(lc:lqmx,lc:lqmx) + integer :: ieswi = 1, ieswc = 1, ieswr = 0 + integer :: iehlsw = 1, iehli = 1, iehlc = 1, iehlr = 0 + integer :: iehwsw = 1, iehwi = 1, iehwc = 1, iehwr = 0 + + logical, parameter :: do_satadj_for_wrfchem = .true. + + + NAMELIST /nssl_mp_params/ & + ndebug, ncdebug,& + iusewetgraupel, & + iusewethail, & + iusewetsnow, & + idbzci, & + vtmaxsed, & + itfall,iscfall, & + infall, & + rssflg, & + sssflg, & + hssflg, & + hlssflg, & + irimdenopt,rimdenvwgt, & + rimc1, rimc2, rimc3, rimc4, & + idiagnosecnu, & + icnuclimit, & + irenuc, & + restoreccn, ccntimeconst, cck, & + ciintmx, & + itype1, itype2, & + icenucopt, & + naer, & + icfn, & + ibfc, iacr, icracr, & + cwfrz2snowfrac, cwfrz2snowratio, & + ibfr, & + ibiggopt, & + ibiggsmallrain, & + ifrzg,ifiacrg, & + ifrzs,ffrzs, & + iacrsize, & + cimas0, cimas1, cfnfac, & + splintermass, & + ewfac, & + eii0, eii1, & + eri0, esi0, & + eri_cimin, & + eii0hl, eii1hl, & + ehs0, ehs1, & + ess0, ess1, & + esstem1,esstem2, & + ircnw, qminrncw,& ! single-moment only + iglcnvi, & + iglcnvs, & + alphahacx, & + fconv, & + eqtot, & + imeyers5, & + iehw, & + ierw, & + iehr0c,iehlr0c, & + alphai, & + alphar, & + alphas, & ! note that alphah and alphahl come through physics namelist + cnu, & + iscni,fscni, & + dfrz, & + dmlt, & + rainfallfac, & + icefallfac, & + snowfallfac, & + graupelfallfac, & + hailfallfac, & + icefallopt, & + icdx,icdxhl, & + cdhmin, cdhmax, & + cdhdnmin, cdhdnmax, & + cdhlmin, cdhlmax, & + cdhldnmin, cdhldnmax, & + ihmlt, & + ehimin, & + ehimax, & + ehsmax, & + ecollmx, & + ehw0, ehlw0, & + ehr0, ehlr0, & + erw0, & + exwmindiam, & + nsplinter, & + lawson_splinter_fac, & + iqcinit, & + ssmxinit, & + xvdmx, & + dhmn, dhmx, & + fwms,fwmh,fwmhl, & + ifwmhopt, & + ihxw2rain, & + fwmlarge, & + ifwmfall, & + iturbenhance, & + qsdenmod,qhdenmod, & + qsvtmod, & + alphamin,alphamax, & + isnwfrac, & + rescale_low_alpha, & + rescale_low_alphar, & + rescale_low_alphah, & + rescale_low_alphahl, & + rescale_high_alpha, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, & + icvhl2h, hldnmn,hdnmn, & + hlcnhdia, hlcnhqmin, & + isedonly, & + iresetmoments, & + cxmin, zxmin, & + imurain, & + iferwisventr, & + izwisventr, & + qhdpvdn, & + qhacidn, & + sheddiam,sheddiamlg, & + sheddiam0, & + mltdiam1,mltdiam2,mltdiam3,mltdiam4,mltdiam05, & + imaxdiaopt, & + ithompsoncnoh, & + cnohmn, & + ivhmltsoak, & + ioldlimiter, & + isnowfall, & + isnowdens, & + ibiggsnow, & + ixtaltype, & + evapfac, & + depfac, & + dmrauto,irescalerainopt, dmropt,dmhlopt, & + rescale_tempthresh, rescale_wthresh, & + ibinhmlr,ibinhlmlr,imltshddmr, binmlrmxdia, binmlrzrrfac,ibinnum, & + iqhacrmlr, iqhlacrmlr, & + snowmeltdia, & + delta_alphamlr, & + iqvsopt, & + maxsupersat, & + charging_border + +! ##################################################################### +! ##################################################################### + + CONTAINS + +! ##################################################################### +! ##################################################################### + + SUBROUTINE wrf_debug( level, message ) + implicit none + integer :: level + character(*) :: message + + IF ( level < 0 ) THEN + write(0,*) message + ENDIF + + END SUBROUTINE wrf_debug + +! +! ##################################################################### +! + SUBROUTINE wrf_message( message ) + implicit none + character(*) :: message + + write(0,*) message + + END SUBROUTINE wrf_message + +! +! ##################################################################### +! + SUBROUTINE wrf_error_fatal( message ) + ! USE COMMASMPI_MODULE, only: commasmpi_abort + implicit none + character(*) :: message + + write(0,*) message + ! call commasmpi_abort() + + END SUBROUTINE wrf_error_fatal + +! +! ##################################################################### +! + + REAL FUNCTION fqvs(t) + implicit none + real :: t + fqvs = exp(caw*(t-273.15)/(t-cbw)) + END FUNCTION fqvs + + REAL FUNCTION fqis(t) + implicit none + real :: t + fqis = exp(cai*(t-273.15)/(t-cbi)) + END FUNCTION fqis + + + + +! ##################################################################### +! ArcHyperbolic tangent to handle only positive values of argument + + REAL FUNCTION myatanh(x) + implicit none + real :: x + + IF ( x >= 0.0 .and. x < 1.0 ) THEN + myatanh = 0.5*( Log((x + 1.0)/(1. - x))) ! 0.5*( Log(x + 1.0) - Log(1. - x)) + ELSEIF ( x >= 1.0 ) THEN + myatanh = 1.e32 + ELSE + myatanh = 0 + ENDIF + + END FUNCTION myatanh + +! ##################################################################### +! ##################################################################### + SUBROUTINE nssl_2mom_init_aero(hgt, nwfa2d, nwfa, nifa, qnn2d, qnn, dx, dy, cccn, & + is_start, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) + +! This subroutine code is mostly borrowed from thompson_init in module_mp_thompson.F +! Here, it is a separate initialization only of things related to aerosols + + IMPLICIT NONE + + INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: hgt + +!..OPTIONAL variables that control application of aerosol-aware scheme + + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), OPTIONAL, INTENT(INOUT) :: qnn,nwfa, nifa + REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL, INTENT(INOUT) :: nwfa2d,qnn2d + REAL, OPTIONAL, INTENT(IN) :: DX, DY, cccn + LOGICAL, OPTIONAL, INTENT(IN) :: is_start + CHARACTER*256:: mp_debug + + + INTEGER:: i, j, k, l, m, n + REAL:: h_01, niIN3, niCCN3, max_test + + REAL, PARAMETER :: eps = 1.E-15 +! LOGICAL:: has_CCN, has_IN + + is_aerosol_aware = .FALSE. +! micro_init = .FALSE. +! has_CCN = .FALSE. +! has_IN = .FALSE. + + + write(mp_debug,*) ' DEBUG checking column of hgt ', its+1,jts+1 + CALL wrf_debug(250, mp_debug) + do k = kts, kte + write(mp_debug,*) ' DEBUGT k, hgt = ', k, hgt(its+1,k,jts+1) + CALL wrf_debug(250, mp_debug) + enddo + + if (PRESENT(qnn2d) .AND. PRESENT(qnn) .AND. PRESENT(nifa)) is_aerosol_aware = .TRUE. + + if (is_aerosol_aware) then + + turn_on_cin = .true. + +!..Check for existing aerosol data, both CCN and IN aerosols. If missing +!.. fill in just a basic vertical profile, somewhat boundary-layer following. + + max_test = MAXVAL ( qnn(its:ite-1,:,jts:jte-1) ) + + if (max_test .lt. eps) then + write(mp_debug,*) ' Apparently there are no initial CCN aerosols, so we will initialize using nssl_cccn value.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' checked column at point (i,j) = ', its,jts + CALL wrf_debug(100, mp_debug) + do j = jts, min(jde-1,jte) + do i = its, min(ide-1,ite) + do k = 1, kte + qnn(i,k,j) = cccn/1.225 ! naCCN1+naCCN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niCCN3) + enddo + enddo + enddo + else +! has_CCN = .TRUE. + write(mp_debug,*) ' Apparently initial CCN aerosols are present.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' column sum at point (i,j) = ', its,jts, SUM(qnn(its,:,jts)) + CALL wrf_debug(100, mp_debug) + endif + + + max_test = MAXVAL ( nifa(its:ite-1,:,jts:jte-1) ) + + if (max_test .lt. eps) then + write(mp_debug,*) ' Apparently there are no initial IN aerosols.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' checked column at point (i,j) = ', its,jts + CALL wrf_debug(100, mp_debug) + do j = jts, min(jde-1,jte) + do i = its, min(ide-1,ite) + if (hgt(i,1,j).le.1000.0) then + h_01 = 0.8 + elseif (hgt(i,1,j).ge.2500.0) then + h_01 = 0.01 + else + h_01 = 0.8*cos(hgt(i,1,j)*0.001 - 1.0) + endif + niIN3 = -1.0*ALOG(naIN1/naIN0)/h_01 + nifa(i,1,j) = naIN1+naIN0*exp(-((hgt(i,2,j)-hgt(i,1,j))/1000.)*niIN3) + do k = 2, kte + nifa(i,k,j) = naIN1+naIN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niIN3) + enddo + enddo + enddo + else +! has_IN = .TRUE. + write(mp_debug,*) ' Apparently initial IN aerosols are present.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' column sum at point (i,j) = ', its,jts, SUM(nifa(its,:,jts)) + CALL wrf_debug(100, mp_debug) + endif + +!..Capture initial state lowest level CCN aerosol data in 2D array. + +! do j = jts, min(jde-1,jte) +! do i = its, min(ide-1,ite) +! qnn2d(i,j) = qnn(i,kts,j) +! enddo +! enddo + +!..Scale the lowest level aerosol data into an emissions rate. This is +!.. very far from ideal, but need higher emissions where larger amount +!.. of existing and lesser emissions where not already lots of aerosols +!.. for first-order simplistic approach. Later, proper connection to +!.. emission inventory would be better, but, for now, scale like this: +!.. where: Nwfa=50 per cc, emit 0.875E4 aerosols per kg per second +!.. Nwfa=500 per cc, emit 0.875E5 aerosols per kg per second +!.. Nwfa=5000 per cc, emit 0.875E6 aerosols per kg per second +!.. for a grid with 20km spacing and scale accordingly for other spacings. + + if (is_start) then + if (SQRT(DX*DY)/20000.0 .ge. 1.0) then + h_01 = 0.875 + else + h_01 = (0.875 + 0.125*((20000.-SQRT(DX*DY))/16000.)) * SQRT(DX*DY)/20000. + endif + write(mp_debug,*) ' aerosol surface flux emission scale factor is: ', h_01 + CALL wrf_debug(100, mp_debug) + do j = jts, min(jde-1,jte) + do i = its, min(ide-1,ite) + ! qnn2d(i,j) = 10.0**(LOG10(qnn(i,kts,j)*1.E-6)-3.69897) + ! qnn2d(i,j) = qnn2d(i,j)*h_01 * 1.E6 + qnn2d(i,j) = (qnn(i,kts,j))/5000. ! same as above -- scale to 5000s for full restore + qnn2d(i,j) = qnn2d(i,j)*h_01 + + nwfa2d(i,j) = 10.0**(LOG10(nwfa(i,kts,j)*1.E-6)-3.69897) + nwfa2d(i,j) = nwfa2d(i,j)*h_01 * 1.E6 + + enddo + enddo +! else +! write(mp_debug,*) ' sample (lower-left) aerosol surface flux emission rate: ', qnn2d(1,1) +! CALL wrf_debug(100, mp_debug) + endif + + endif + + + + RETURN +END SUBROUTINE nssl_2mom_init_aero + +! ##################################################################### +! ##################################################################### + + + SUBROUTINE nssl_2mom_init( & + & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & + & nssl_graupelfallfac, & + & nssl_hailfallfac, & + & nssl_ehw0, & + & nssl_ehlw0, & + & nssl_icdx, & + & nssl_icdxhl, & + & nssl_icefallfac, & + & nssl_snowfallfac & + ) + + + implicit none + + real, intent(in), optional :: & + & nssl_graupelfallfac, & + & nssl_hailfallfac, & + & nssl_ehw0, & + & nssl_ehlw0, & + & nssl_icefallfac, & + & nssl_snowfallfac + integer, intent(in), optional :: & + & nssl_icdx, & + & nssl_icdxhl + + integer, intent(in) :: ims,ime, jms,jme, kms,kme + real, intent(in), dimension(20) :: nssl_params + + + + integer, intent(in) :: ipctmp,mixphase,ihvol + logical, optional, intent(in) :: idoniconlytmp + double precision :: arg + real :: temq + integer :: igam + integer :: i,il,j,l + integer :: ltmp + integer :: isub + real :: bxh,bxhl + + real :: alp,ratio + double precision :: x,y,y2,y7 + logical :: turn_on_ccna + integer :: istat + + + turn_on_ccna = .false. +! turn_on_cin = .false. +! +! set some global values from namelist input +! + + ccn = Abs( nssl_params(1) ) + alphah = nssl_params(2) + alphahl = nssl_params(3) + cnoh = nssl_params(4) + cnohl = nssl_params(5) + cnor = nssl_params(6) + cnos = nssl_params(7) + rho_qh = nssl_params(8) + rho_qhl = nssl_params(9) + rho_qs = nssl_params(10) + +! ipelec = Nint(nssl_params(11)) +! isaund = Nint(nssl_params(12)) + IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac + IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac + IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0 + IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0 + IF ( present(nssl_icdx) ) icdx = nssl_icdx + IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl + IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac + IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac + + + IF ( Nint(nssl_params(13)) == 1 ) THEN + ! hack to switch CCN field to CCNA (activated ccn) +! invertccn = .true. + turn_on_ccna = .true. + irenuc = 7 + ENDIF + + + + + + + + IF ( irenuc >= 5 ) THEN + turn_on_ccna = .true. + ENDIF + + cwccn = ccn + + lhab = 8 + lhl = 8 + IF ( icespheres >= 1 ) THEN + lhab = lhab + 1 + lis = li + 1 + ls = ls + 1 + lh = lh + 1 + lhl = lhl + 1 + ENDIF + IF ( ihvol <= -1 .or. ihvol == 2 ) THEN + IF ( ihvol == -1 .or. ihvol == -2 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + ! past me thought it would be a good idea to change graupel factors when hail is off.... + ! ehw0 = 0.75 + ! iehw = 2 + ! dfrz = Max( dfrz, 0.5e-3 ) + ENDIF + IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off + ! a value of -3 means to turn off ice crystals but turn on hail + renucfrac = 1.0 + ffrzs = 1.0 + ! idoci = 0 ! try this later + ENDIF + ENDIF + +! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl + +! IF ( ipelec > 0 ) idonic = .true. + +! +! Build lookup table for saturation mixing ratio (Soong and Ogura 73) +! + + do l = 1,nqsat + temq = 163.15 + (l-1)*fqsat + IF ( iqvsopt == 0 ) THEN + tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) + dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + & + & caw/(temq - cbw))*tabqvs(l) + ELSE + tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) + dtabqvs(l) = ((-cawbolton*(-273.15 + temq))/(temq - cbwbolton)**2 + & + & cawbolton/(temq - cbwbolton))*tabqvs(l) + ENDIF + tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) + dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + & + & cai/(temq - cbi))*tabqis(l) + end do + + bx(lr) = 0.85 + ax(lr) = 1647.81 + fx(lr) = 135.477 + + IF ( icdx == 6 ) THEN + bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550. + ax(lh) = 157.71 + ELSEIF ( icdx > 0 ) THEN + bx(lh) = 0.5 + ax(lh) = 75.7149 + ELSE + bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 + ax(lh) = 19.3 + ENDIF +! bx(lh) = 0.6 + + IF ( lhl .gt. 1 ) THEN + IF ( icdxhl == 6 ) THEN + bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750. + ax(lhl) = 179.36 + ELSEIF (icdxhl > 0 ) THEN + bx(lhl) = 0.5 + ax(lhl) = 75.7149 + ELSE + ax(lhl) = 206.984 ! Ferrier 1994 + bx(lhl) = 0.6384 + ENDIF + ENDIF + +! fill in the complete gamma function lookup table + gmoi(0) = 1.d32 + do igam = 1,ngm0 + arg = dgam*igam + gmoi(igam) = gamma_dp(arg) + end do + + ! build lookup table to compute the number and mass fractions of rain drops + ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr + ! Uses incomplete gamma functions + ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) + + bxh = bx(lh) + bxhl = bx(Max(lh,lhl)) + +! DO j = 0,nqiacralpha + DO j = ialpstart,nqiacralpha + alp = float(j)*dqiacralpha + y = gamma_dpr(1.+alp) + y2 = gamma_dpr(2.+alp) + DO i = 0,nqiacrratio + ratio = float(i)*dqiacrratio + x = gamxinfdp( 1.+alp, ratio ) +! write(0,*) 'i, x/y = ',i, x/y + ciacrratio(i,j) = x/y + + ! graupel (.,.,.,1) + gamxinflu(i,j,1,1) = x/y + gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y + gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y + gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y + gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y + gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y + gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y + + gamxinflu(i,j,12,1) = gamxinfdp( 2.0+alp, ratio )/y2 + + ! hail (.,.,.,2) + gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) + gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) + gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y + gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1) + gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y + gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1) + gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1) + + IF ( alp > 1.1 ) THEN +! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y + gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y +! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y +! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y + ELSE +! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y + gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y +! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y +! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y + gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y + ENDIF + + gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) + + ENDDO + ENDDO + ciacrratio(0,:) = 1.0 + + DO j = ialpstart,nqiacralpha + alp = float(j)*dqiacralpha + y = gamma_sp(4.+alp) + y7 = gamma_sp(7.+alp) + DO i = 0,nqiacrratio + ratio = float(i)*dqiacrratio + + ! mass fraction + x = gamxinfdp( 4.+alp, ratio ) +! write(0,*) 'i, x/y = ',i, x/y + qiacrratio(i,j) = x/y + gamxinflu(i,j,4,1) = x/y + gamxinflu(i,j,4,2) = x/y + + ! reflectivity fraction + x = gamxinfdp( 7.+alp, ratio ) + ziacrratio(i,j) = x/y7 + gamxinflu(i,j,11,1) = x/y7 + gamxinflu(i,j,11,2) = x/y7 + + ENDDO + ENDDO + qiacrratio(0,:) = 1.0 + + + isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0 + + lccn = 0 + lccna = 0 + lnc = 0 + lnr = 0 + lni = 0 + lnis = 0 + lns = 0 + lnh = 0 + lnhl = 0 + lvh = 0 + lvhl = 0 + lzr = 0 + lzh = 0 + lzhl = 0 + lsw = 0 + lhw = 0 + lhlw = 0 + + denscale(:) = 0 + +! lccn = 9 + + ipconc = ipctmp + + IF ( ipconc == 0 ) THEN + IF ( ihvol >= 0 ) THEN + lvh = 9 + ltmp = 9 + denscale(lvh) = 1 + ELSE ! no hail + ltmp = lhab + lhl = 0 + ENDIF + ELSEIF ( ipconc == 5 ) THEN + lccn = lhab+1 ! 9 + lnc = lhab+2 ! 10 + lnr = lhab+3 ! 11 + lni = lhab+4 !12 + lns = lhab+5 !13 + lnh = lhab+6 !14 + ltmp = lnh + IF ( ihvol >= 0 ) THEN + ltmp = ltmp + 1 + lnhl = ltmp ! lhab+7 ! 15 + ENDIF + ltmp = ltmp + 1 + lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off +! ltmp = lvh + denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + ltmp = ltmp + 1 + lvhl = ltmp +! ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + IF ( mixedphase ) THEN + ltmp = ltmp + 1 + lsw = ltmp + ltmp = ltmp + 1 + lhw = ltmp + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lhlw = ltmp + ENDIF +! ltmp = lhlw + ENDIF + ELSEIF ( ipconc >= 6 ) THEN + write(0,*) 'NSSL microphysics has not been compiled for 3-moment. Sorry.' + STOP + lccn = lhab+1 ! 9 + lnc = lhab+2 ! 10 + lnr = lhab+3 ! 11 + lni = lhab+4 !12 + lns = lhab+5 !13 + lnh = lhab+6 !14 + ltmp = lnh + IF ( lhl > 0 ) THEN + ltmp = ltmp + 1 + lnhl = ltmp ! lhab+7 ! 15 + ENDIF + ltmp = ltmp + 1 + lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off +! ltmp = lvh + denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + ltmp = ltmp + 1 + lvhl = ltmp +! ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + + IF ( ipconc == 6 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ELSEIF ( ipconc == 7 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ltmp = ltmp + 1 + lzr = ltmp + ELSEIF ( ipconc == 8 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ltmp = ltmp + 1 + lzr = ltmp + ltmp = ltmp + 1 + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lzhl = ltmp + ENDIF + ENDIF +! ltmp = lvh + ! denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + lvhl = ltmp+1 + ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + IF ( mixedphase ) THEN + ltmp = ltmp + 1 + lsw = ltmp + ltmp = ltmp + 1 + lhw = ltmp + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lhlw = ltmp + ENDIF +! ltmp = lhlw + ENDIF + ELSE + CALL wrf_error_fatal( 'nssl_2mom_init: Invalid value of ipctmp' ) + ENDIF + + + + + ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna + IF ( turn_on_ccna ) THEN + ltmp = ltmp + 1 + lccna = ltmp + denscale(ltmp) = 1 + ENDIF + + IF ( turn_on_cin .or. is_aerosol_aware ) THEN + ltmp = ltmp + 1 + lcin = ltmp + denscale(ltmp) = 1 +!debug write(0,*) 'Setting lcin to ',lcin + ENDIF + na = ltmp + + ln(lc) = lnc + ln(lr) = lnr + ln(li) = lni + ln(ls) = lns + ln(lh) = lnh + IF ( lhl .gt. 1 ) ln(lhl) = lnhl + + ipc(lc) = 2 + ipc(lr) = 3 + ipc(li) = 1 + ipc(ls) = 4 + ipc(lh) = 5 + IF ( lhl .gt. 1 ) ipc(lhl) = 5 + + ldovol = .false. + lvol(:) = 0 + lvol(li) = lvi + lvol(ls) = lvs + lvol(lh) = lvh + IF ( lhl .gt. 1 .and. lvhl .gt. 1 ) lvol(lhl) = lvhl + + lne = Max(lnh,lnhl) + lne = Max(lne,lvh) + lne = Max(lne,lvhl) + lne = Max(lne,na) + + lsc(:) = 0 + lsc(lc) = lscw + lsc(lr) = lscr + lsc(li) = lsci + lsc(ls) = lscs + lsc(lh) = lsch + IF ( lhl .gt. 1 ) lsc(lhl) = lschl + + + DO il = lc,lhab + ldovol = ldovol .or. ( lvol(il) .gt. 1 ) + ENDDO + +! write(0,*) 'nssl_2mom_init: ldovol = ',ldovol + + lz(:) = 0 + lz(lr) = lzr + lz(li) = lzi + lz(ls) = lzs + lz(lh) = lzh + IF ( lhl .gt. 1 .and. lzhl > 1 ) lz(lhl) = lzhl + + lliq(:) = 0 + lliq(ls) = lsw + lliq(lh) = lhw + IF ( lhl .gt. 1 ) lliq(lhl) = lhlw + IF ( mixedphase ) THEN +! write(0,*) 'lsw,lhw,lhlw = ',lsw,lhw,lhlw + ENDIF + + + + xnu(lc) = cnu + xmu(lc) = 1. + + IF ( imurain == 3 ) THEN + xnu(lr) = rnu + xmu(lr) = 1. + ELSEIF ( imurain == 1 ) THEN + xnu(lr) = (alphar - 2.0)/3.0 + xmu(lr) = 1./3. + ENDIF + + xnu(li) = cinu + xmu(li) = 1. + + IF ( lis >= 1 ) THEN + xnu(lis) = 0.0 + xmu(lis) = 1. + ENDIF + + dnu(lc) = 3.*xnu(lc) + 2. ! alphac + dmu(lc) = 3.*xmu(lc) + + dnu(lr) = 3.*xnu(lr) + 2. ! alphar + dmu(lr) = 3.*xmu(lr) + + xnu(ls) = snu + xmu(ls) = 1. + + dnu(ls) = 3.*xnu(ls) + 2. ! -0.4 ! alphas + dmu(ls) = 3.*xmu(ls) + + + dnu(lh) = alphah + dmu(lh) = dmuh + + xnu(lh) = (dnu(lh) - 2.)/3. + xmu(lh) = dmuh/3. + + + IF ( imurain == 3 ) THEN ! rain is gamma of volume + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ & + & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr))) + +! IF ( ipconc .lt. 5 ) alphahl = alphah + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + xnu(lr)))/ & + & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(2. + xnu(lr))) + + rzs = 1. ! assume rain and snow are both gamma volume + + ELSE ! rain is gamma of diameter + + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + + rzs = & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)*(2. + xnu(ls)))/ & + & ((4. + alphar)*(5. + alphar)*(6. + alphar)*(1. + xnu(ls))) + + + ENDIF + + IF ( ipconc <= 5 ) THEN + imltshddmr = Min(1, imltshddmr) + ibinhmlr = 0 + ibinhlmlr = 0 + ENDIF + + IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN + imltshddmr = Min(1, imltshddmr) + ENDIF + +! write(0,*) 'rz,rzhl = ', rz,rzhl + + IF ( ipconc .lt. 4 ) THEN + + dnu(ls) = alphas + dmu(ls) = 1. + + xnu(ls) = (dnu(ls) - 2.)/3. + xmu(ls) = 1./3. + + + ENDIF + + IF ( lhl .gt. 1 ) THEN + + dnu(lhl) = alphahl + dmu(lhl) = dmuhl + + xnu(lhl) = (dnu(lhl) - 2.)/3. + xmu(lhl) = dmuhl/3. + + ENDIF + + cno(lc) = 1.0e+08 + IF ( li .gt. 1 ) cno(li) = 1.0e+08 + cno(lr) = cnor + IF ( ls .gt. 1 ) cno(ls) = cnos ! 8.0e+06 + IF ( lh .gt. 1 ) cno(lh) = cnoh ! 4.0e+05 + IF ( lhl .gt. 1 ) cno(lhl) = cnohl ! 4.0e+05 +! +! density maximums and minimums +! + xdnmx(:) = 900.0 + + xdnmx(lr) = 1000.0 + xdnmx(lc) = 1000.0 + xdnmx(li) = 917.0 + xdnmx(ls) = 300.0 + xdnmx(lh) = 900.0 + IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 +! + xdnmn(:) = 900.0 + + xdnmn(lr) = 1000.0 + xdnmn(lc) = 1000.0 + xdnmn(li) = 100.0 + xdnmn(ls) = 100.0 + xdnmn(lh) = hdnmn + IF ( lhl .gt. 1 ) xdnmn(lhl) = hldnmn + + xdn0(:) = 900.0 + + xdn0(lc) = 1000.0 + xdn0(li) = 900.0 + xdn0(lr) = 1000.0 + xdn0(ls) = rho_qs ! 100.0 + xdn0(lh) = rho_qh ! (0.5)*(xdnmn(lh)+xdnmx(lh)) + IF ( lhl .gt. 1 ) xdn0(lhl) = rho_qhl ! 800.0 + +! +! Set terminal velocities... +! also set drag coefficients +! + cdx(lr) = 0.60 + cdx(lh) = 0.8 ! 1.0 ! 0.45 + cdx(ls) = 2.00 + IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 + + ido(lc) = idocw + ido(lr) = idorw + ido(li) = idoci + ido(ls) = idosw + ido(lh) = idohw + IF ( lhl .gt. 1 ) ido(lhl) = idohl + + IF ( irfall .lt. 0 ) irfall = infall + IF ( lzr > 0 ) irfall = 0 + + qccn = ccn/rho00 +! xvcmx = (4./3.)*pi*xcradmx**3 + +! set max rain diameter + IF ( xvdmx .gt. 0.0 ) THEN + xvrmx = 0.523599*(xvdmx)**3 + ELSE + xvrmx = xvrmx0 + ENDIF + + IF ( dhmn <= 0.0 ) THEN + xvhmn = xvhmn0 +! xvhmn = Min(xvhmn0, 0.523599*(dfrz)**3 ) + ELSE + xvhmn = 0.523599*(dhmn)**3 +! xvhmn = 0.523599*(Min(dhmn,dfrz))**3 + ENDIF + + IF ( dhmx <= 0.0 ) THEN + xvhmx = xvhmx0 + ELSE + xvhmx = 0.523599*(dhmx)**3 + ENDIF + + IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh) + IF ( qhacidn < 0. ) qhacidn = xdnmn(lh) + +! load max/min diameters + xvmn(lc) = xvcmn + xvmn(li) = xvimn + xvmn(lr) = xvrmn + xvmn(ls) = xvsmn + xvmn(lh) = xvhmn + + xvmx(lc) = xvcmx + xvmx(li) = xvimx + xvmx(lr) = xvrmx + xvmx(ls) = xvsmx + xvmx(lh) = xvhmx + + IF ( lhl .gt. 1 ) THEN + xvmn(lhl) = xvhlmn + xvmx(lhl) = xvhlmx + ENDIF + +! +! cloud water constants in mks units +! +! cwmasn = 4.25e-15 ! radius of 1.0e-6 +! cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 +! cwmasn5 = 5.23e-13 +! cwradn = 5.0e-6 ! minimum radius +! cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 +! mwfac = 6.0**(1./3.) + IF ( ipconc .ge. 2 ) THEN +! cwmasn = xvmn(lc)*1000. ! minimum mass, defined by minimum droplet volume +! cwradn = 1.0e-6 ! minimum radius +! cwmasx = xvmx(lc)*1000. ! maximum mass, defined by maximum droplet volume + + ENDIF +! rwmasn = xvmn(lr)*1000. ! minimum mass, defined by minimum rain volume +! rwmasx = xvmx(lr)*1000. ! maximum mass, defined by maximum rain volume + + IF ( lhl < 1 ) ifrzg = 1 + + ventr = 1. + IF ( imurain == 3 ) THEN +! IF ( izwisventr == 1 ) THEN + ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985 +! ELSE + ventrn = Gamma_sp(rnu + 1.5 + br/6.)/(Gamma_sp(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ! adapted from Wisner et al. 1972; for second term in rwvent +! ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985, still use for first term in rwvent +! ventr = Gamma_sp(rnu + 4./3.)/Gamma_sp(rnu + 1.) +! ENDIF + ELSE ! imurain == 1 +! IF ( iferwisventr == 1 ) THEN + ventr = Gamma_sp(2. + alphar) ! Ferrier 1994 +! ELSEIF ( iferwisventr == 2 ) THEN + ventrn = Gamma_sp(alphar + 2.5 + br/2.)/Gamma_sp(alphar + 1.) ! adapted from Wisner et al. 1972 +! ENDIF + ENDIF + ventc = Gamma_sp(cnu + 4./3.)/(cnu + 1.)**(1./3.)/Gamma_sp(cnu + 1.) + c1sw = Gamma_sp(snu + 4./3.)*(snu + 1.0)**(-1./3.)/gamma_sp(snu + 1.0) + + ! set threshold mixing ratios + + qxmin(:) = 1.0e-12 + + qxmin(lc) = 1.e-9 + qxmin(lr) = 1.e-7 + IF ( li > 1 ) qxmin(li) = 1.e-12 + IF ( ls > 1 ) qxmin(ls) = 1.e-7 + IF ( lh > 1 ) qxmin(lh) = 1.e-7 + IF ( lhl .gt. 1 ) qxmin(lhl) = 1.e-7 + + IF ( lc .gt. 1 .and. lnc .gt. 1 ) qxmin(lc) = 1.0e-13 + IF ( lr .gt. 1 .and. lnr .gt. 1 ) qxmin(lr) = 1.0e-12 + + IF ( li .gt. 1 .and. lni .gt. 1 ) qxmin(li ) = 1.0e-13 + IF ( ls .gt. 1 .and. lns .gt. 1 ) qxmin(ls ) = 1.0e-13 + IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12 + IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12 + + ! constants for droplet nucleation + + cckm = cck-1. + ccnefac = (1.63/(cck * beta(3./2., cck/2.)))**(cck/(cck + 2.0)) + cnexp = (3./2.)*cck/(cck+2.0) +! ccne is all the factors with w in eq. A7 in Mansell et al. 2010 (JAS). The constant changes +! if k (cck) is changed! + ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) + ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck)) +! write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp + IF ( cwccn .lt. 0.0 ) THEN + cwccn = Abs(cwccn) + ccwmx = 50.e9 ! cwccn + ELSE + ccwmx = 50.e9 ! cwccn ! *1.4 + ENDIF + +! +! +! Set collection coefficients (Seifert and Beheng 05) +! + bb(:) = 1.0/3.0 + bb(li) = 0.3429 + DO il = lc,lhab + da0(il) = delbk(bb(il), xnu(il), xmu(il), 0) + da1(il) = delbk(bb(il), xnu(il), xmu(il), 1) + +! write(0,*) 'il, da0, da1, xnu, xmu = ', il, da0(il), da1(il), xnu(il), xmu(il) + ENDDO + + dab0(:,:) = 0.0 + dab1(:,:) = 0.0 + + DO il = lc,lhab + DO j = lc,lhab + IF ( il .ne. j ) THEN + + dab0(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 0) + dab1(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 1) + +! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j) + ENDIF + ENDDO + ENDDO + + gf4br = gamma_sp(4.0+br) + gf4ds = gamma_sp(4.0+ds) + gf4p5 = gamma_sp(4.0+0.5) + gfcinu1 = gamma_sp(cinu + 1.0) + gfcinu1p47 = gamma_sp(cinu + 1.47167) + gfcinu2p47 = gamma_sp(cinu + 2.47167) + gfcinu1p22 = gamma_sp(cinu + 1.22117) + gfcinu2p22 = gamma_sp(cinu + 2.22117) + gfcinu1p18 = gamma_sp(cinu + 1.18333) + gfcinu2p18 = gamma_sp(cinu + 2.18333) + + gsnow1 = gamma_sp(snu + 1.0) + gsnow53 = gamma_sp(snu + 5./3.) + gsnow73 = gamma_sp(snu + 7./3.) + + IF ( lh .gt. 1 ) cwchtmp0 = 6.0/pi*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) + IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) + + + iexy(:,:)=0; ! sets to zero the ones Imight have forgotten + +! snow + iexy(ls,li) = ieswi + iexy(ls,lc) = ieswc ; iexy(ls,lr) = ieswr ; + +! graupel + iexy(lh,ls) = iehwsw ; iexy(lh,li) = iehwi ; + iexy(lh,lc) = iehwc ; iexy(lh,lr) = iehwr ; + +! hail + IF (lhl .gt. 1 ) THEN + iexy(lhl,ls) = iehlsw ; iexy(lhl,li) = iehli ; + iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; + ENDIF + + IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac + IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac + + + RETURN +END SUBROUTINE nssl_2mom_init + +! ##################################################################### +! ##################################################################### + +SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & + cn, vhw, vhl, cna, f_cn, f_cna, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + tt, th, pii, p, w, dn, dz, dtp, itimestep, & + RAINNC,RAINNCV, & + dx, dy, & + axtra, & + SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & + SR,HAILNC, HAILNCV, & + tkediss, & + re_cloud, re_ice, re_snow, & + has_reqc, has_reqi, has_reqs, & + rainncw2, rainnci2, & + dbz, vzf,compdbz, & + rscghis_2d,rscghis_2dp,rscghis_2dn, & + scr,scw,sci,scs,sch,schl,sctot, & + induc,elec,scion,sciona, & + noninduc,noninducp,noninducn, & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2, & +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & + ipelectmp, & + diagflag,ke_diag, & + NWFA, f_qnwfa, & + NIFA, f_qnifa, & + nwfa2d, & + qnn2d, & + nssl_progn, & ! wrf-chem +! 20130903 acd_mb_washout start + rainprod, evapprod, & ! wrf-chem +! 20130903 acd_mb_washout end + cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte) ! tile dims + + + +#if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) +#define MPI + USE module_dm, ONLY : & + local_communicator, mytask +! keep a spacing line here to keep Apple cpp from adding a space in front of the endif +#endif + + implicit none + +#if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) || defined(MPI) + INCLUDE 'mpif.h' +#else + integer :: mytask = 0 + +#endif + + !Subroutine arguments: + + integer, intent(in):: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + qv,qc,qr,qs,qh + ! tt is air temperature -- used by CCPP instead of th (theta) + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + th, tt, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna + real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz + real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate + rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) + rscghis_2dn ! 2D accumulation arrays for vertically-integrated charging rate (negative only) +! real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elec ! elecsave = Ez + real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn + + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2 +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail + + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra + +! WRF variables + real, dimension(ims:ime, jms:jme), intent(inout):: & + RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout):: & + SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout):: & + HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: & + re_cloud, re_ice, re_snow, nwfa, nifa + real, dimension(ims:ime, jms:jme), intent(in), optional :: nwfa2d,qnn2d + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs + real, dimension(ims:ime, jms:jme), intent(out), optional :: & + rainncw2, rainnci2 ! liquid rain, ice, accumulation rates + real, optional, intent(in) :: dx,dy + real, intent(in):: dtp + integer, intent(in):: itimestep !, ccntype + logical, optional, intent(in) :: diagflag, f_cna, f_cn + integer, optional, intent(in) :: ipelectmp, ke_diag + + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem + LOGICAL, INTENT(IN), OPTIONAL :: f_qnifa , f_qnwfa ! flags for Thompson aero + +! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop + LOGICAL :: flag_qndrop ! wrf-chem + LOGICAL :: flag_qnifa , flag_qnwfa + real :: cinchange, t7max,testmax,wmax + +! 20130903 acd_ck_washout start +! rainprod - total tendency of conversion of cloud water/ice and graupel to rain (kg kg-1 s-1) +! evapprod - tendency of evaporation of rain (kg kg-1 s-1) +! 20130903 acd_ck_washout end + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: rainprod, evapprod + +! qrcuten, rain tendency from parameterized cumulus convection +! qscuten, snow tendency from parameterized cumulus convection +! qicuten, cloud ice tendency from parameterized cumulus convection +! mu : air mass in column + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: qrcuten, qscuten, qicuten, qccuten + INTEGER, optional, intent(in) :: cu_used + +! +! local variables +! + real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab +! real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+ + real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d + real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten + real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d + real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 + real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d + real, dimension(its:ite, 1, na) :: xfall + integer, parameter :: nor = 0, ng = 0 + integer :: nx,ny,nz + integer ix,jy,kz,i,j,k,il,n + integer :: infdo + real :: ssival, ssifac, t8s, t9s, qvapor + integer :: ltemq + double precision :: dp1 + integer :: jye, lnb + integer :: imx,kmx + real :: dbzmx,refl + integer :: vzflag0 = 0 + logical :: makediag + real, parameter :: cnin20 = 1.0e3 + real, parameter :: cnin10 = 5.0e1 + real, parameter :: cnin1a = 4.5 + real, parameter :: cnin2a = 12.96 + real, parameter :: cnin2b = 0.639 + + double precision :: cwmass1,cwmass2 + double precision :: rwmass1,rwmass2 + double precision :: icemass1,icemass2 + double precision :: swmass1,swmass2 + double precision :: grmass1,grmass2 + double precision :: hlmass1,hlmass2 + double precision :: wvol5,wvol10 + real :: tmp,dv,dv1 + real :: rdt + + double precision :: dt1,dt2 + double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed + double precision :: timevtcalc,timesetvt + + logical :: f_cnatmp + + integer :: kediagloc + integer :: iunit + +#ifdef MPI + +#if defined(MPI) + integer, parameter :: ntot = 50 + double precision mpitotindp(ntot), mpitotoutdp(ntot) + INTEGER :: mpi_error_code = 1 +#endif +#endif + + +! ------------------------------------------------------------------- + + + rdt = 1.0/dtp + +! write(0,*) 'N2M: entering routine' + + flag_qndrop = .false. + flag_qnifa = .false. + flag_qnwfa = .false. + + IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn + + IF ( PRESENT ( f_qnifa ) ) flag_qnifa = f_qnifa + IF ( PRESENT ( f_qnwfa ) ) flag_qnwfa = f_qnwfa + + + + ! --- + + IF ( present( f_cna ) ) THEN + f_cnatmp = f_cna + ELSE + f_cnatmp = .false. + ENDIF + + IF ( present( vzf ) ) vzflag0 = 1 + + IF ( present( ipelectmp ) ) THEN + ipelec = ipelectmp + ELSE + ipelec = 0 + ENDIF +! IF ( present( dbz ) ) THEN +! DO jy = jts,jte +! DO kz = kts,kte +! DO ix = its,ite +! dbz(ix,kz,jy) = 0.0 +! ENDDO +! ENDDO +! ENDDO +! ENDIF + + + makediag = .true. + IF ( present( diagflag ) ) THEN + makediag = diagflag .or. itimestep == 1 + ENDIF + +! write(0,*) 'N2M: makediag = ',makediag + + + nx = ite-its+1 + ny = 1 ! set up as 2D slabs + nz = kte-kts+1 + + IF ( .not. present( cn ) ) THEN + renucfrac = 1.0 + ENDIF + +! set up CCN array and some other static local values + IF ( .false. ) THEN + IF ( itimestep == 1 .and. .not. invertccn .and. present( cn ) ) THEN + ! this is not needed for WRF 3.8 and later because it is done in physics_init, + ! but kept for backwards compatibility with earlier versions + IF ( cn((ite+its)/2,(kte+kts)/2,(jte+jts)/2) < 10.0 ) THEN ! initialize ccn if not already done + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cn(ix,kz,jy) = qccn + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + IF ( itimestep == 1 .and. invertccn .and. present( cn ) ) THEN + ! this is not needed for WRF 3.8 and later because it is done in physics_init, + ! but kept for backwards compatibility with earlier versions + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cn(ix,kz,jy) = 0.0 + ENDDO + ENDDO + ENDDO + ENDIF + + IF ( invertccn .and. present( cn ) ) THEN ! hack for WRF to convert activated ccn to unactivated, then do not have to + ! worry about initial and boundary conditions - they are zero + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + ! cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + +! ENDIF ! itimestep == 1 + +! sedimentation settings + + infdo = 2 + + IF ( infall .ne. 1 .or. iscfall .ge. 2 ) THEN + infdo = 1 + ELSE + infdo = 0 + ENDIF + + IF ( infall .ge. 3 .or. ipconc .ge. 6 ) THEN + infdo = 2 + ENDIF + + + IF ( present( HAILNCV ) .and. lhl < 1 ) THEN ! for WRF 3.1 compatibility + HAILNCV(its:ite,jts:jte) = 0. + ENDIF + + tke2d(:,:) = 0.0 ! initialize if not used + + lnb = Max(lh,lhl)+1 ! lnc +! IF ( lccn > 1 ) lnb = lccn + + jye = jte + + IF ( present( compdbz ) .and. makediag ) THEN + DO jy = jts,jye + DO ix = its,ite + compdbz(ix,jy) = -3.0 + ENDDO + ENDDO + ENDIF + + zmaxsed = 0.0d0 + timevtcalc = 0.0d0 + timesetvt = 0.0d0 + timesed = 0.0d0 + timesed1 = 0.0d0 + timesed2 = 0.0d0 + timesed3 = 0.0d0 + timegs = 0.0d0 + timenucond = 0.0d0 + + + +! write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) + + ancuten(its:ite,1,kts:kte,:) = 0.0 + + DO jy = jts,jye + + xfall(:,:,:) = 0.0 + +! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn + + IF ( present( pcc2 ) .and. makediag ) THEN + axtra2d(its:ite,1,kts:kte,:) = 0.0 + ENDIF + + ! copy from 3D array to 2D slab + + DO kz = kts,kte + DO ix = its,ite + + IF ( present( tt ) ) THEN + an(ix,1,kz,lt) = tt(ix,kz,jy)/pii(ix,kz,jy) + ELSE + an(ix,1,kz,lt) = th(ix,kz,jy) + ENDIF + + + an(ix,1,kz,lv) = qv(ix,kz,jy) + an(ix,1,kz,lc) = qc(ix,kz,jy) + an(ix,1,kz,lr) = qr(ix,kz,jy) + IF ( present( qi ) ) THEN + an(ix,1,kz,li) = qi(ix,kz,jy) + ELSE + an(ix,1,kz,li) = 0.0 + ENDIF + an(ix,1,kz,ls) = qs(ix,kz,jy) + an(ix,1,kz,lh) = qh(ix,kz,jy) + IF ( lhl > 1 ) an(ix,1,kz,lhl) = qhl(ix,kz,jy) + IF ( lccn > 1 ) THEN + IF ( is_aerosol_aware .and. flag_qnwfa ) THEN + an(ix,1,kz,lccn) = nwfa(ix,kz,jy) + ELSEIF ( present( cn ) ) THEN + IF ( invertccn ) THEN + an(ix,1,kz,lccn) = qccn - cn(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = cn(ix,kz,jy) + ENDIF + ELSE + IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN + an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = qccn + ENDIF + + ENDIF + ENDIF + + IF ( lccna > 1 ) THEN + IF ( present( cna ) .and. f_cnatmp ) THEN + an(ix,1,kz,lccna) = cna(ix,kz,jy) + ENDIF + ENDIF + + IF ( lcin > 1 .and. flag_qnifa ) THEN + an(ix,1,kz,lcin) = nifa(ix,kz,jy) + ENDIF + + IF ( ipconc >= 5 ) THEN + an(ix,1,kz,lnc) = ccw(ix,kz,jy) + IF ( constccw > 0.0 ) THEN + an(ix,1,kz,lnc) = constccw + ENDIF + an(ix,1,kz,lnr) = crw(ix,kz,jy) + IF ( present( cci ) ) THEN + an(ix,1,kz,lni) = cci(ix,kz,jy) + ELSE + an(ix,1,kz,lni) = 0.0 + ENDIF + an(ix,1,kz,lns) = csw(ix,kz,jy) + an(ix,1,kz,lnh) = chw(ix,kz,jy) + IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,kz,jy) + ENDIF + IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy) + IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy) + + + + + + + IF ( present( tt ) ) THEN + t0(ix,1,kz) = tt(ix,kz,jy) ! temperature (Kelvin) + ELSE + t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin) + ENDIF + t1(ix,1,kz) = 0.0 + t2(ix,1,kz) = 0.0 + t3(ix,1,kz) = 0.0 + t4(ix,1,kz) = 0.0 + t5(ix,1,kz) = 0.0 + t6(ix,1,kz) = 0.0 + t7(ix,1,kz) = 0.0 + t8(ix,1,kz) = 0.0 + t9(ix,1,kz) = 0.0 + t00(ix,1,kz) = 380.0/p(ix,kz,jy) + t77(ix,1,kz) = pii(ix,kz,jy) + dbz2d(ix,1,kz) = 0.0 + vzf2d(ix,1,kz) = 0.0 + + dn1(ix,1,kz) = dn(ix,kz,jy) + pn(ix,1,kz) = p(ix,kz,jy) + wn(ix,1,kz) = w(ix,kz,jy) +! wmax = Max(wmax,wn(ix,1,kz)) + dz2d(ix,1,kz) = dz(ix,kz,jy) + dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy) + + ltemq = Int( (t0(ix,1,kz)-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) +! +! saturation mixing ratio +! + t8s = t00(ix,1,kz)*tabqvs(ltemq) !saturation mixing ratio wrt water + t9s = t00(ix,1,kz)*tabqis(ltemq) !saturation mixing ratio wrt ice + +! +! calculate rate of nucleation +! + ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + + if ( ssival .gt. 1.0 ) then +! + IF ( icenucopt == 1 ) THEN + + if ( t0(ix,1,kz).le.268.15 ) then + + dp1 = dn1(ix,1,kz)/rho00*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) + t7(ix,1,kz) = Min(dp1, 1.0d30) + end if + +! +! Default value of imeyers5 turns off nucleation by Meyer at higher temperatures +! This is really from Ferrier (1994), eq. 4.31 - 4.34 + IF ( imeyers5 ) THEN + if ( t0(ix,1,kz).lt.tfr .and. t0(ix,1,kz).gt.268.15 ) then + qvapor = max(an(ix,1,kz,lv),0.0) + ssifac = 0.0 + if ( (qvapor-t9s) .gt. 1.0e-5 ) then + if ( (t8s-t9s) .gt. 1.0e-5 ) then + ssifac = (qvapor-t9s) /(t8s-t9s) + ssifac = ssifac**cnin1a + end if + end if + t7(ix,1,kz) = dn1(ix,1,kz)/rho00*cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1) + end if + ENDIF + +! t7max = Max(t7max, t7(ix,1,kz) ) + + ELSEIF ( icenucopt == 2 ) THEN ! Thompson/Cooper; Note Thompson 2004 has constants of + ! 0.005 and 0.304 because the line function was estimated from Cooper plot + ! Here, the fit line values from Cooper 1986 are converted. Very little difference + ! in practice + + t7(ix,1,kz) = 1000.*0.00446684*exp(0.3108*(273.16 - Max(233.0, t0(ix,1,kz) ) ) ) ! factor of 1000 to convert L**-1 to m**-3 + +! write(0,*) 'Cooper t7,ssival = ',ix,kz,t7(ix,1,kz),ssival + + ELSEIF ( icenucopt == 3 ) THEN ! Phillips (Meyers/DeMott) + + if ( t0(ix,1,kz).le.268.15 .and. t0(ix,1,kz) > 243.15 ) then ! Meyers with factor of Psi=0.06 + + dp1 = 0.06*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) + t7(ix,1,kz) = Min(dp1, 1.0d30) + elseif ( t0(ix,1,kz) <= 243.15 ) then ! Phillips estimate of DeMott et al (2003) data + dp1 = 1000.*( exp( Min( 57.0 ,cnin2a*(ssival-1.1) ) ) )**0.3 + t7(ix,1,kz) = Min(dp1, 1.0d30) + + end if + + ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 + + IF ( t0(ix,jy,kz) < 268.16 .and. t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + + ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033, + ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d) + ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00 + ! naer needs units of cm**-3, so mult by 1.e-6 + + ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) + dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) + t7(ix,jy,kz) = Min(dp1, 1.0d30) + + ELSE + t7(ix,jy,kz) = 0.0 + ENDIF + + ENDIF ! icenucopt + + +! + end if ! ( ssival .gt. 1.0 ) +! + + ENDDO ! ix + ENDDO ! kz + + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF + + + ! transform from number mixing ratios to number conc. + + DO il = lnb,na + IF ( denscale(il) == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy) + ENDDO + ENDDO + ENDIF + ENDDO ! il + +! sedimentation + xfall(:,:,:) = 0.0 + + IF ( .true. ) THEN + + +! #ifndef CM1 +! for real cases when hydrometeor mixing ratios have been initialized without concentrations + IF ( itimestep == 1 .and. ipconc > 0 ) THEN + call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) + ENDIF +! #endif + + IF ( present(cu_used) .and. & + ( present( qrcuten ) .or. present( qscuten ) .or. & + present( qicuten ) .or. present( qccuten ) ) ) THEN + + IF ( cu_used == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + + IF ( present( qrcuten ) ) ancuten(ix,1,kz,lr) = dtp*qrcuten(ix,kz,jy) + IF ( present( qscuten ) ) ancuten(ix,1,kz,ls) = dtp*qscuten(ix,kz,jy) + IF ( present( qicuten ) ) ancuten(ix,1,kz,li) = dtp*qicuten(ix,kz,jy) + IF ( present( qccuten ) ) ancuten(ix,1,kz,lc) = dtp*qccuten(ix,kz,jy) + + ENDDO + ENDDO + + call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) + + + ENDIF + + ENDIF + + + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & + & t0,t7,infdo,jy,its,jts & + & ,timesed1,timesed2,timesed3,zmaxsed,timesetvt) + + +! copy xfall to appropriate places... + +! write(0,*) 'N2M: end sediment, jy = ',jy + + DO ix = its,ite + IF ( lhl > 1 ) THEN + RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) + ELSE + RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) ) + ENDIF + IF ( present ( rainncw2 ) ) THEN ! rain only + rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) + ENDIF + IF ( present ( rainnci2 ) ) THEN ! ice only + IF ( lhl > 1 ) THEN + rainnci2(ix,jy) =rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) + ELSE + rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) ) + ENDIF + ENDIF + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) + IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) + + IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + IF ( lhl > 1 ) THEN +!#ifdef CM1 +! IF ( .true. ) THEN +!#else + IF ( present( HAILNC ) ) THEN +!#endif + HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) + ELSEIF ( present( GRPLNCV ) ) THEN + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + ENDIF + ENDIF + IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) + IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN + IF ( present( HAILNC ) ) THEN + SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) + ELSE + SR(ix,jy) = (SNOWNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) + ENDIF + ENDIF + ENDDO + + ENDIF ! .false. + + IF ( isedonly /= 1 ) THEN + ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics + +! write(0,*) 'N2M: gs, jy = ',jy +! IF ( isedonly /= 2 ) THEN + + + IF ( .true. ) THEN + call nssl_2mom_gs & + & (nx,ny,nz,na,jy & + & ,nor,nor & + & ,dtp,dz2d & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn1,t77 & + & ,pn,wn,0 & + & ,t00,t77, & + & ventr,ventc,c1sw,1,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & + & cdx, & + & xdn0,dbz2d,tke2d, & + & timevtcalc,axtra2d, makediag & + & ,rainprod2d, evapprod2d & + & ,elec2,its,ids,ide,jds,jde & + & ) + ENDIF + + + + + + ENDIF ! isedonly /= 1 + + ! droplet nucleation/condensation/evaporation + IF ( .true. ) THEN + CALL NUCOND & + & (nx,ny,nz,na,jy & + & ,nor,nor,dtp,nx & + & ,dz2d & + & ,t0,t9 & + & ,an,dn1,t77 & + & ,pn,wn & + & ,axtra2d, makediag & + & ,ssat,t00,t77,flag_qndrop) + + + ENDIF + + + IF ( present( pcc2 ) .and. makediag ) THEN + DO kz = kts,kte + DO ix = its,ite +! example of using the 'axtra2d' array to get rates out of the microphysics routine for output. +! Search for 'axtra' to find example code below +! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1) + + ENDDO + ENDDO + ENDIF + + +! compute diagnostic S-band reflectivity if needed + IF ( present( dbz ) .and. makediag ) THEN + ! calc dbz + + IF ( .true. ) THEN + IF ( present(ke_diag) ) THEN + kediagloc = ke_diag + ELSE + kediagloc = nz + ENDIF + call radardd02(nx,ny,nz,nor,na,an,t0, & + & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0) + ENDIF ! .false. + + + DO kz = kts,kediagloc ! kte + DO ix = its,ite + dbz(ix,kz,jy) = dbz2d(ix,1,kz) + IF ( present( vzf ) ) THEN + vzf(ix,kz,jy) = vzf2d(ix,1,kz) + IF ( dbz2d(ix,1,kz) <= 0.0 ) THEN + vzf(ix,kz,jy) = 0.0 + ELSEIF ( dbz2d(ix,1,kz) <= 15.0 ) THEN + refl = 10**(0.1*dbz2d(ix,1,kz)) + vzf(ix,kz,jy) = Min( vzf2d(ix,1,kz), 2.6 * Max(0.0,refl)**0.107 * (1.2/dn1(ix,1,kz))**0.4 ) + ENDIF + ENDIF + IF ( present( compdbz ) ) THEN + compdbz(ix,jy) = Max( compdbz(ix,jy), dbz2d(ix,1,kz) ) + ENDIF + ENDDO + ENDDO + + ENDIF + + + +! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F + IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & + present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN + IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = 2.51E-6 + re_ice(ix,kz,jy) = 10.01E-6 + re_snow(ix,kz,jy) = 25.E-6 + t1(ix,1,kz) = 2.51E-6 + t2(ix,1,kz) = 10.01E-6 + t3(ix,1,kz) = 25.E-6 + ENDDO + ENDDO + + call calc_eff_radius & + & (nx,ny,nz,na,jy & + & ,nor,nor & + & ,t1,t2,t3 & + & ,an,dn1 ) + + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6)) + re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 125.E-6)) + re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) + ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation) + IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) + ENDDO + ENDDO + + ENDIF + ENDIF + + + + +! transform concentrations back to mixing ratios + DO il = lnb,na + IF ( denscale(il) == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy) + ENDDO + ENDDO + ENDIF + ENDDO ! il + + ! copy 2D slabs back to 3D + + + DO kz = kts,kte + DO ix = its,ite + + IF ( present( tt ) ) THEN + tt(ix,kz,jy) = t0(ix,1,kz) + ELSE + th(ix,kz,jy) = an(ix,1,kz,lt) + ENDIF + + qv(ix,kz,jy) = an(ix,1,kz,lv) + qc(ix,kz,jy) = an(ix,1,kz,lc) + qr(ix,kz,jy) = an(ix,1,kz,lr) + IF ( present(qi) ) qi(ix,kz,jy) = an(ix,1,kz,li) + qs(ix,kz,jy) = an(ix,1,kz,ls) + qh(ix,kz,jy) = an(ix,1,kz,lh) + IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) + + IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN + nwfa(ix,kz,jy) = an(ix,1,kz,lccn) +! nwfa(ix,kz,jy) = Min(1.5e9, nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp) + IF ( kz == 1 ) nwfa(ix,kz,jy) = nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp + ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN + IF ( invertccn ) THEN + cn(ix,kz,jy) = qccn - an(ix,1,kz,lccn) + ELSE + cn(ix,kz,jy) = an(ix,1,kz,lccn) + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + IF ( present( cna ) .and. f_cnatmp ) THEN + cna(ix,kz,jy) = an(ix,1,kz,lccna) + ENDIF + ENDIF + + IF ( lcin > 1 .and. flag_qnifa ) THEN + nifa(ix,kz,jy) = an(ix,1,kz,lcin) + ENDIF + + IF ( ipconc >= 5 ) THEN + + ccw(ix,kz,jy) = an(ix,1,kz,lnc) + crw(ix,kz,jy) = an(ix,1,kz,lnr) + IF ( present( cci ) ) cci(ix,kz,jy) = an(ix,1,kz,lni) + csw(ix,kz,jy) = an(ix,1,kz,lns) + chw(ix,kz,jy) = an(ix,1,kz,lnh) + IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl) + ENDIF + + + + + IF ( lvh > 0 ) vhw(ix,kz,jy) = an(ix,1,kz,lvh) + IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl) + +#ifdef WRF_CHEM + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) + IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) + ENDIF +#endif + ENDDO + ENDDO + + ENDDO ! jy + + IF ( invertccn .and. present( cn ) ) THEN ! hack to convert unactivated ccn back to activated + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite +! cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) + ENDDO + ENDDO + ENDDO + ENDIF + + + + + + RETURN +END SUBROUTINE nssl_2mom_driver + +! ##################################################################### +! ##################################################################### + + REAL FUNCTION GAMMA_SP(xx) + + implicit none + real xx + integer j + +! Double precision ser,stp,tmp,x,y,cof(6) + + real*8 ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d+0, & + & -86.50532032941677d0, & + & 24.01409824083091d0, & + & -1.231739572450155d0, & + & 0.1208650973866179d-2,& + & -0.5395239384953d-5, & + & 2.5066282746310005d0/ + + IF ( xx <= 0.0 ) THEN + write(0,*) 'Argument to gamma must be > 0!! xx = ',xx + STOP + ENDIF + + x = xx + y = x + tmp = x + 5.5d0 + tmp = (x + 0.5d0)*Log(tmp) - tmp + ser = 1.000000000190015d0 + DO j=1,6 + y = y + 1.0d0 + ser = ser + cof(j)/y + END DO + gamma_sp = Exp(tmp + log(stp*ser/x)) + + RETURN + END FUNCTION GAMMA_SP + +! ##################################################################### + + DOUBLE PRECISION FUNCTION GAMMA_DPR(x) + ! dp gamma with real input + implicit none + real :: x + double precision :: xx + + xx = x + + gamma_dpr = gamma_dp(xx) + + return + end FUNCTION GAMMA_DPR + + + + +! ##################################################################### + + real function GAMXINF(A1,X1) + +! =================================================== +! Purpose: Compute the incomplete gamma function +! from x to infinity +! Input : a --- Parameter ( a 170 ) +! x --- Argument +! Output: GIM --- gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing gamma(x) +! =================================================== + +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + real :: a1,x1 + double precision :: xam,dlog,s,r,ga,t0,a,x + integer :: k + double precision :: gin, gim + + a = a1 + x = x1 + IF ( x1 <= 0.0 ) THEN + gamxinf = GAMMA_SP(A1) + return + ENDIF + XAM=-X+A*DLOG(X) + IF (XAM.GT.700.0.OR.A.GT.170.0) THEN + WRITE(*,*)'a and/or x too large' + STOP + ENDIF + IF (X.EQ.0.0) THEN + GIN=0.0 + GIM = GAMMA_SP(A1) + ELSE IF (X.LE.1.0+A) THEN + S=1.0D0/A + R=S + DO 10 K=1,60 + R=R*X/(A+K) + S=S+R + IF (DABS(R/S).LT.1.0D-15) GO TO 15 +10 CONTINUE +15 GIN=DEXP(XAM)*S + ga = GAMMA_SP(A1) + GIM=GA-GIN + ELSE IF (X.GT.1.0+A) THEN + T0=0.0D0 + DO 20 K=60,1,-1 + T0=(K-A)/(1.0D0+K/(X+T0)) +20 CONTINUE + GIM=DEXP(XAM)/(X+T0) +! GA = GAMMA_SP(A1) +! GIN=GA-GIM + ENDIF + + gamxinf = GIM + return + END function GAMXINF + +! ##################################################################### + + double precision function GAMXINFDP(A1,X1) + +! =================================================== +! Purpose: Compute the incomplete gamma function +! from x to infinity +! Input : a --- Parameter ( a < 170 ) +! x --- Argument +! Output: GIM --- Gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing gamma_dp(x) +! =================================================== + +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + real :: a1,x1 +! dont declare gamma_dp because it is within the module +! double precision :: gamma_dp + double precision :: xam,dlog,s,r,ga,t0,a,x + integer :: k + double precision :: gin, gim + + a = a1 + x = x1 + IF ( x1 <= 0.0 ) THEN + gamxinfdp = GAMMA_DP(A) + return + ENDIF + XAM=-X+A*DLOG(X) + IF (XAM.GT.700.0.OR.A.GT.170.0) THEN + WRITE(*,*)'a and/or x too large' + STOP + ENDIF + IF (X.EQ.0.0) THEN + GIN=0.0 + GIM = GAMMA_dp(A) + ELSE IF (X.LE.1.0+A) THEN + S=1.0D0/A + R=S + DO 10 K=1,60 + R=R*X/(A+K) + S=S+R + IF (DABS(R/S).LT.1.0D-15) GO TO 15 +10 CONTINUE +15 GIN=DEXP(XAM)*S + ga = GAMMA_DP(A) + GIM=GA-GIN + ELSE IF (X.GT.1.0+A) THEN + T0=0.0D0 + DO 20 K=60,1,-1 + T0=(K-A)/(1.0D0+K/(X+T0)) +20 CONTINUE + GIM=DEXP(XAM)/(X+T0) +! GA = GAMMA_dp(A) +! GIN=GA-GIM + ENDIF + + gamxinfdp = GIM + return + END function GAMXINFDP + + +! ##################################################################### + +! #ifdef Z3MOM + real function gaminterp(ratio, alp, luindex, ilh) + + implicit none + + real, intent(in) :: ratio, alp + integer, intent(in) :: ilh ! 1 = graupel, 2 = hail + integer, intent(in) :: luindex ! which argument: + ! gamxinflu(i,j,1,1) = x/y + ! gamxinflu(i,j,2,1) = gamxinf( 2.0+alp, ratio )/y + ! gamxinflu(i,j,3,1) = gamxinf( 2.5+alp+0.5*bxh, ratio )/y + ! gamxinflu(i,j,5,1) = gamxinf( 5.0+alp, ratio )/y + ! gamxinflu(i,j,6,1) = gamxinf( 5.5+alp+0.5*bxh, ratio )/y + + + real :: delx, dely, tmp1, tmp2, temp3 + integer :: i,j,ip1,jp1 !,ilh + +! ilh = Abs(ilh0) + + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + delx = Min(maxratiolu,ratio) - float(i)*dqiacrratio + dely = alp - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = gamxinflu(i,j,luindex,ilh) + delx*dqiacrratioinv* & + & (gamxinflu(ip1,j,luindex,ilh) - gamxinflu(i,j,luindex,ilh)) + tmp2 = gamxinflu(i,jp1,luindex,ilh) + delx*dqiacrratioinv* & + & (gamxinflu(ip1,jp1,luindex,ilh) - gamxinflu(i,jp1,luindex,ilh)) + + ! interpolate along alpha; + + gaminterp = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1)) + + ! debug +! IF ( ilh0 < 0 ) THEN +! write(0,*) 'gaminterp: ',i,j,ilh,ratio,delx,dely,gamxinflu(i,j,luindex,ilh),tmp1,tmp2 +! ENDIF + + END FUNCTION gaminterp +! #endif /* Z3MOM */ +! ##################################################################### + +!**************************** GAML02 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 40 micron drops) +! ********************************************************** + real FUNCTION GAML02(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=12) + real gamxg(ng), xg(ng) + DATA xg/0.01,0.02,0.025,0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 7.391019203578037e-8,0.02212726874591478,0.06959352407989682, & + & 0.2355654024970809,0.46135930387500346,0.545435791452399, & + & 0.7371571313308203, & + & 0.8265676632204345,0.8640182781845841,0.8855756211304151, & + & 0.9245079225301251, & + & 0.9712578342732681/ + IF ( x .ge. xg(ng) ) THEN + gaml02 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + gaml02 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + gaml02 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02 + +!**************************** GAML02d300 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb) +! ********************************************************** + real FUNCTION GAML02d300(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=9) + real gamxg(ng), xg(ng) + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 0.0, & + & 7.391019203578011e-8,0.0002260640810600053, & + & 0.16567071824457152, & + & 0.4231369044918005,0.5454357914523988, & + & 0.6170290936864555, & + & 0.7471346054110058,0.9037156157718299 / + IF ( x .ge. xg(ng) ) THEN + GAML02d300 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + GAML02d300 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + GAML02d300 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02d300 +!c + +! ##################################################################### +! ##################################################################### + +!**************************** GAML02 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 500 micron drops) (see zieglerstuff.nb) +! ********************************************************** + real FUNCTION GAML02d500(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=9) + real gamxg(ng), xg(ng) + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 0.0,0.0, & + & 2.2346039e-13, 0.0221272687459, & + & 0.23556540, 0.38710348, & + & 0.48136183,0.6565833, & + & 0.86918315 / + IF ( x .ge. xg(ng) ) THEN + GAML02d500 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + GAML02d500 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + GAML02d500 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02d500 +!c + +! ##################################################################### + +! ##################################################################### + + + real function BETA(P,Q) +! +! ========================================== +! Purpose: Compute the beta function B(p,q) +! Input : p --- Parameter ( p > 0 ) +! q --- Parameter ( q > 0 ) +! Output: BT --- B(p,q) +! Routine called: GAMMA for computing gamma(x) +! ========================================== +! +! IMPLICIT real (A-H,O-Z) + implicit none + double precision p1,gp,q1,gq, ppq,gpq + real p,q + + p1 = p + q1 = q + CALL GAMMADP(P1,GP) + CALL GAMMADP(Q1,GQ) + PPQ=P1+Q1 + CALL GAMMADP(PPQ,GPQ) + beta=GP*GQ/GPQ + RETURN + END function BETA + +! ##################################################################### +! ##################################################################### + + DOUBLE PRECISION FUNCTION GAMMA_DP(xx) + + implicit none + double precision xx + integer j + +! Double precision ser,stp,tmp,x,y,cof(6) + + real*8 ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d+0, & + & -86.50532032941677d0, & + & 24.01409824083091d0, & + & -1.231739572450155d0, & + & 0.1208650973866179d-2,& + & -0.5395239384953d-5, & + & 2.5066282746310005d0/ + + x = xx + y = x + tmp = x + 5.5d0 + tmp = (x + 0.5d0)*Log(tmp) - tmp + ser = 1.000000000190015d0 + DO j=1,6 + y = y + 1.0d0 + ser = ser + cof(j)/y + END DO + gamma_dp = Exp(tmp + log(stp*ser/x)) + + RETURN + END function gamma_dp +! ##################################################################### + + SUBROUTINE GAMMADP(X,GA) +! +! ================================================== +! Purpose: Compute gamma function Gamma(x) +! Input : x --- Argument of Gamma(x) +! ( x is not equal to 0,-1,-2,...) +! Output: GA --- gamma(x) +! ================================================== +! +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + + double precision, parameter :: PI=3.141592653589793D0 + double precision :: x,ga,z,r,gr + integer :: k,m1,m + + double precision :: G(26) + + IF (X.EQ.INT(X)) THEN + IF (X.GT.0.0D0) THEN + GA=1.0D0 + M1=X-1 + DO K=2,M1 + GA=GA*K + ENDDO + ELSE + GA=1.0D+300 + ENDIF + ELSE + IF (DABS(X).GT.1.0D0) THEN + Z=DABS(X) + M=INT(Z) + R=1.0D0 + DO K=1,M + R=R*(Z-K) + ENDDO + Z=Z-M + ELSE + Z=X + ENDIF + DATA G/1.0D0,0.5772156649015329D0, & + & -0.6558780715202538D0, -0.420026350340952D-1, & + & 0.1665386113822915D0,-.421977345555443D-1, & + & -.96219715278770D-2, .72189432466630D-2, & + & -.11651675918591D-2, -.2152416741149D-3, & + & .1280502823882D-3, -.201348547807D-4, & + & -.12504934821D-5, .11330272320D-5, & + & -.2056338417D-6, .61160950D-8, & + & .50020075D-8, -.11812746D-8, & + & .1043427D-9, .77823D-11, & + & -.36968D-11, .51D-12, & + & -.206D-13, -.54D-14, .14D-14, .1D-15/ + GR=G(26) + DO K=25,1,-1 + GR=GR*Z+G(K) + ENDDO + GA=1.0D0/(GR*Z) + IF (DABS(X).GT.1.0D0) THEN + GA=GA*R + IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X)) + ENDIF + ENDIF + RETURN + END SUBROUTINE GAMMADP + + +! ##################################################################### +! ##################################################################### +! +! +! ##################################################################### + Function delbk(bb,nu,mu,k) +! +! Purpose: Caluculates collection coefficients following Siefert (2006) +! +! delbk is equation (90) (b collecting b -- self-collection) +! mass-diameter relationship: D = a*x**(b), where x = particle mass +! general distribution: n(x) = A*x**(nu)*Exp(-lam*x**(mu)) +! where +! A = mu*N/(Gamma((nu+1)/mu)) *lam**((nu+1)/mu) +! +! lam = ( Gamma((nu+1)/mu)/Gamma((nu+2)/mu) * xbar )**(-mu) +! +! where xbar = L/N (mass content)/(number concentration) = q*rhoa/N +! + + implicit none + real delbk + real nu, mu, bb + integer k + + real tmp, del + real x1, x2, x3, x4 + integer i + + tmp = ((1.0 + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x1 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((2.0 + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x2 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1.0 + 2.0*bb + k + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x3 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! delbk = & +! & ((Gamma_sp((1.0 + nu)/mu)/Gamma_sp((2.0 + nu)/mu))**(2.0*bb + k)* & +! & Gamma_sp((1.0 + 2.0*bb + k + nu)/mu))/Gamma_sp((1.0 + nu)/mu) + + delbk = & + & ((x1/x2)**(2.0*bb + k)* & + & x3)/x1 + + RETURN + END Function delbk + +! ##################################################################### +! +! +! ##################################################################### +! Equation (91) in Seifert and Beheng (2006) ("a" collecting "b") + Function delabk(ba,bb,nua,nub,mua,mub,k) + + implicit none + real delabk + real nua, mua, ba + integer k + real nub, mub, bb + + integer i + real tmp,del + + real g1pnua, g2pnua, g1pbapnua, g1pbbpk, g1pnub, g2pnub + + tmp = (1. + nua)/mua + i = Int(dgami*(tmp)) + del = tmp - dgam*i + IF ( i+1 > ngm0 ) THEN + write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp + STOP + ENDIF + g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua) + + tmp = ((2. + nua)/mua) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g2pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + ba + nua)/mua) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pbapnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((2 + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g2pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + bb + k + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pbbpk = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + delabk = & + & (2.*(g1pnua/g2pnua)**ba* & + & g1pbapnua* & + & (g1pnub/g2pnub)**(bb + k)* & + & g1pbbpk)/ & + & (g1pnua*g1pnub) + + RETURN + END Function delabk + + +! ##################################################################### +! +! ##################################################################### +!-------------------------------------------------------------------------- + subroutine cld_cpu(string) + + implicit none + character( LEN = * ) string + + return + + end subroutine cld_cpu + +! +!-------------------------------------------------------------------------- +! +!-------------------------------------------------------------------------- +! + subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & + & t0,t7,infdo,jslab,its,jts, & + & timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing +! +! Sedimentation driver -- column by column +! +! Written by ERM 10/2011 +! +! +! + implicit none + + integer nx,ny,nz,nor,norz,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density + integer :: its,jts ! SW point of local tile + + integer ng1 + parameter(ng1 = 1) + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real dz3dinv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + +! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) + real dtp + real xfall(nx,ny,na) ! array for stuff landing on the ground + real xfall0(nx,ny) ! dummy array + integer infdo + integer jslab ! which line of xfall to use + + integer ix,jy,kz,ndfall,n,k,il,in + real tmp, vtmax, dtptmp, dtfrac + real, parameter :: dz = 200. + + real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted + real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) + real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + + real :: rhovtzx(nz,nx) + + double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy + double precision :: dt1,dt2,dt3,dt4 + + integer,parameter :: ngs = 128 + integer :: ngscnt,mgs,ipconc0 + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + logical :: hasmass(nx,lc+1:lhab) + + integer igs(ngs),kgs(ngs) + + real rho0(ngs),temcg(ngs) + + real temg(ngs) + + real rhovt(ngs) + + real cwnc(ngs),cinc(ngs) + real fadvisc(ngs),cwdia(ngs),cipmas(ngs) + + real cimasn,cimasx,cnina(ngs),cimas(ngs) + + real cnostmp(ngs) + + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + integer :: plo, phi + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + + + + kzb = 1 + kze = nz + + ixb = 1 + ixe = nx + + + jy = 1 + jgs = jy + + +! +! zero the precip flux arrays (2d) +! + + xvt(:,:,:,:) = 0.0 + + if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' + + + DO kz = kzb,kze + DO ix = ixb,ixe + db1(ix,kz) = dn(ix,jy,kz) + db1inv(ix,kz) = 1./dn(ix,jy,kz) + rhovtzx(kz,ix) = Sqrt(rho00*db1inv(ix,kz) ) + ENDDO + ENDDO + + DO kz = kzb,kze + DO ix = ixb,ixe + dtz1(kz,ix,0) = dz3dinv(ix,jy,kz) + dtz1(kz,ix,1) = dz3dinv(ix,jy,kz)*db1inv(ix,kz) + dz2dinv(kz,ix) = dz3dinv(ix,jy,kz) + ENDDO + ENDDO + + IF ( lzh .gt. 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + an(ix,jy,kz,lzh) = Max( 0., an(ix,jy,kz,lzh) ) + ENDDO + ENDDO + ENDIF + + + DO il = lc+1,lhab + DO ix = ixb,ixe +! hasmass(ix,il) = Any( an(ix,jy,:,il) > qxmin(il) ) + ENDDO + ENDDO + + + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3a2' + +! loop over columns + DO ix = ixb,ixe + + dummy = 0.d0 + + + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,0 & + & ) + + +! loop over each species and do sedimentation for all moments + DO il = lc,lhab + IF ( ido(il) == 0 ) CYCLE + +! IF ( .not. hasmass(ix,il) ) CYCLE + +! plo = nz +! phi = 0 + + + vtmax = 0.0 + + do kz = kzb,kze + + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) + + vtmax = Max(vtmax,xvt(kz,ix,1,il)*dz2dinv(kz,ix)) + vtmax = Max(vtmax,xvt(kz,ix,2,il)*dz2dinv(kz,ix)) + vtmax = Max(vtmax,xvt(kz,ix,3,il)*dz2dinv(kz,ix)) + +! IF ( dtp*xvt(kz,ix,1,il)*dz2dinv(kz,ix) >= 0.7 .or. & +! & dtp*xvt(kz,ix,2,il)*dz2dinv(kz,ix) >= 0.7 .or. & +! & dtp*xvt(kz,ix,3,il)*dz2dinv(kz,ix) >= 0.7 ) THEN +! +! zmaxsed = Max(zmaxsed, float(kz) ) +!! plo = Min(plo,kz) +!! phi = Max(phi,kz) +! +! ENDIF + + ENDDO + + IF ( vtmax == 0.0 ) CYCLE + + + + IF ( dtp*vtmax .lt. 0.7 ) THEN ! check whether multiple steps are needed. + ndfall = 1 + ELSE + IF ( dtp > 20.0 ) THEN ! more stringent subdivision for large time steps + ndfall = Max(2, Int(dtp*vtmax/0.7) + 1) + ELSE ! more relaxed for small time steps, but might still be a problem for very thin vertical layers near the ground + ndfall = 1+Int(dtp*vtmax + 0.301) + ENDIF + ENDIF + + IF ( ndfall .gt. 1 ) THEN + dtptmp = dtp/Real(ndfall) +! write(0,*) 'subdivide fallout on its,jts,ix,plo,phi = ',its,jts,ix,plo,phi +! write(0,*) 'for il,jsblab,c,ndfall = ',il,jslab,dtp*vtmax,ndfall + ELSE + dtptmp = dtp + ENDIF + + dtfrac = dtptmp/dtp + + + DO n = 1,ndfall + + IF ( do_accurate_sedimentation .and. n .ge. 2 ) THEN +! +! zero the precip flux arrays (2d) +! + +! xvt(:,:,:,il) = 0.0 + dummy = 0.d0 + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,il) + + + DO kz = kzb,kze + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) + ENDDO + + + + + ENDIF ! (n .ge. 2) + + + IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN + IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN + call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & + & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix ) + ENDIF + ENDIF + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b' + +! mixing ratio + + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & an,db1,il,1,xfall,dtz1,ix) + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3c' + +! volume + + IF ( ldovol .and. il >= li ) THEN + IF ( lvol(il) .gt. 1 ) THEN + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & an,db1,lvol(il),0,xfall,dtz1,ix) + ENDIF + ENDIF + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' + + + IF ( ipconc .gt. 0 ) THEN !{ + IF ( ipconc .ge. ipc(il) ) THEN + + IF ( ( infall .ge. 2 .or. (infall .eq. 0 .and. il .lt. lh) ) .and. lz(il) .lt. 1) THEN !{ +! +! load number conc. into tmpn to do fallout by mass-weighted mean fall speed +! to put a lower bound on number conc. +! + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or. & + & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN + + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn2(ix,jy,kz) = z(ix,kz,il) +! ENDDO + ENDDO + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) +! ENDDO + ENDDO + + ELSE + + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) +! ENDDO + ENDDO + + ENDIF + + ENDIF !} + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f' + + in = 2 + IF ( infall .eq. 1 ) in = 1 + + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), & + & an,db1,ln(il),0,xfall,dtz1,ix) + + + IF ( lz(il) .lt. 1 ) THEN ! if not 3-moment, run one of the correction schemes + IF ( (infall .ge. 2 .or. infall .eq. 3) .and. .not. (infall .eq. 0 .and. il .ge. lh) & + & .and. ( il .eq. lr .or. (il .ge. li .and. il .le. lhab) )) THEN +! : .or. il .eq. lhl )) THEN + + xfall0(:,jgs) = 0.0 + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & + & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & + & tmpn2,db1,1,0,xfall0,dtz1,ix) + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & tmpn,db1,1,0,xfall0,dtz1,ix) + ELSE + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & tmpn,db1,1,0,xfall0,dtz1,ix) + ENDIF + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & + & .or. il .ge. lh ) ) THEN +! "Method I" - dbz correction + + call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & + & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, & + & lvol(il), rho_qh, infall, ix) + + ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN + + DO kz = kzb,kze +! DO ix = ixb,ixe + an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), 0.5* ( an(ix,jgs,kz,ln(il)) + tmpn(ix,jy,kz) )) + +! ENDDO + ENDDO + + ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN +! "Method II" M-wgt N-fallout correction + + DO kz = kzb,kze +! DO ix = ixb,ixe + + an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), tmpn(ix,jy,kz) ) + +! ENDDO + ENDDO + ENDIF + ENDIF ! lz(il) .lt. 1 + + + ENDIF + ENDIF + + + ENDIF !} + + + ENDDO ! n=1,ndfall + ENDDO ! il + + ENDDO ! ix + + + + + RETURN + END SUBROUTINE SEDIMENT1D + + +! ##################################################################### + +! +! ##################################################################### + + +! +!-------------------------------------------------------------------------- +! +!-------------------------------------------------------------------------- +! + subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & + & a,db1,ia,id,xfall,dtz1,ixcol) +! +! First-order, upwind fallout scheme +! +! Written by ERM 6/10/2011 +! +! +! + implicit none + + integer nx,ny,nz,nor,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density + integer ng1 + parameter(ng1 = 1) + integer :: ixcol + +! real dz3dinv(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) +! real a(nx,ny,nz,na) + real a(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) ! quantity to be 'advected' + real vt(nz+1,nx) ! terminal speed for a + real dtp,dtfrac + real cmax + real xfall(nx,ny,na) ! array for stuff landing on the ground + real db1(nx,nz+1),dtz1(nz+1,nx,0:1) + +! Local + + integer ix,jy,kz,n,k + integer iv1,iv2 + real tmp + integer imn,imx,kmn,kmx + real qtmp1(nz+1) + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + jy = 1 + + iv1 = 0 + iv2 = 0 + + imn = nx + imx = 1 + kmn = nz + kmx = 1 + + cmax = 0.0 + + kzb = 1 + kze = nz + + ixb = ixcol + ixe = ixcol + ix = ixcol + + qtmp1(nz+1) = 0.0 + + DO kz = kzb,kze +! DO ix = ixb,ixe +! cmax = Max(cmax, vt(ix,kz)*dz3dinv(ix,jy,kz)) + + IF ( id == 1 ) THEN + qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix)*db1(ix,kz) + ELSE + qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix) + ENDIF + + IF ( a(ix,jgs,kz,ia) .ne. 0.0 ) THEN +! imn = Min(ix,imn) +! imx = Max(ix,imx) + kmn = Min(kz,kmn) + kmx = Max(kz,kmx) + ENDIF +! ENDDO + ENDDO + + kmn = Max(1,kmn-1) + +! first check if fallout is worth doing +! IF ( cmax .eq. 0.0 .or. imn .gt. imx ) THEN +! RETURN +! ENDIF + + IF ( kmn == 1 ) THEN + + kz = 1 +! do ix = imn,imx ! 1,nx-1 + xfall(ix,jy,ia) = xfall(ix,jy,ia) + a(ix,jgs,kz,ia)*vt(kz,ix)*dtfrac +! enddo + + ENDIF + + do kz = 1,nz +! do ix = 1,nx + a(ix,jgs,kz,ia) = a(ix,jgs,kz,ia) + dtp*dtz1(kz,ix,id)*(qtmp1(kz+1) - qtmp1(kz) ) +! enddo + enddo + + + RETURN + END SUBROUTINE FALLOUT1D + +! ############################################################################## +! ############################################################################## + + subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & + & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol) + + + implicit none + + integer nx,ny,nz,nor,na,ngt,jgs + integer :: ixcol + integer, parameter :: norz = 3 + real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) + real z(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! reflectivity + real db(nx,nz+1) ! air density +! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt) + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer l ! index for q + integer ln ! index for N + integer lvol ! index for volume + real rho_qx + + + integer ix,jy,kz + real vr,qr,nrx,rd,xv,g1,zx,chw,xdn + + + jy = jgs + ix = ixcol + + IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN + + + DO kz = 1,kze + + + + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN + + IF ( lvol .gt. 1 ) THEN + IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN + xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) + xdn = Min( 900., Max( hdnmn, xdn ) ) + ELSE + xdn = rho_qx + ENDIF + ELSE + xdn = rho_qx + ENDIF + + IF ( l == lr ) xdn = 1000. + + qr = a(ix,jy,kz,l) + xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + chw = a(ix,jy,kz,ln) + + IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN + xv = Min( xvmx, Max( xvmn,xv ) ) + chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + ENDIF + + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & + & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) + zx = g1*db(ix,kz)**2*(a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw +! z(ix,kz,l) = 1.e18*zx*(6./(pi*1000.))**2 + z(ix,kz,l) = zx*(6./(pi*1000.))**2 + + +! IF ( ny.eq.2 .and. kz .ge. 25 .and. kz .le. 29 .and. z(ix,kz,l) .gt. 0. ) THEN +! write(*,*) 'calczgr: z,dbz,xdn = ',ix,kz,z(ix,kz,l),10*log10(z(ix,kz,l)),xdn +! ENDIF + + ELSE + + z(ix,kz,l) = 0.0 + + ENDIF + + ENDDO + + ELSEIF ( l .eq. lr .and. imurain == 3) THEN + + xdn = 1000. + + DO kz = 1,kze + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) +! z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) + z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) +! qr = a(ix,jy,kz,lr) +! nrx = a(ix,jy,kz,lnr) + + ELSE + + z(ix,kz,l) = 0.0 + + ENDIF + + + ENDDO + + ENDIF + + RETURN + + END subroutine calczgr1d + +! ############################################################################## +! ############################################################################## +! +! Subroutine to correct number concentration to prevent reflectivity growth by +! sedimentation in 2-moment ZXX scheme. +! Calculation is in a slab (constant jgs) +! + + subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & + & z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, & + & lvol, rho_qx, infall, ixcol) + + + implicit none + + integer nx,ny,nz,nor,na,ngt,jgs,ixcol + + real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) ! sedimented N and q + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented reflectivity + real t1(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented N (by Vm) +! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt) + real z0(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! initial reflectivity + + real db(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer l ! index for q + integer ln ! index for N + integer lvol ! index for volume + real rho_qx + integer infall + + + integer ix,jy,kz + double precision vr,qr,nrx,rd,g1,zx,chw,z,znew,zt,zxt + real xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + + ndbz = 0 + nmwgt = 0 + nnwgt = 0 + nwlessthanz = 0 + + + + jy = jgs + ix = ixcol + + IF ( l .eq. lh .or. l .eq. lhl .or. ( l == lr .and. imurain == 1 ) ) THEN + + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & + & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) + + DO kz = 1,kze + + + IF ( t0(ix,jy,kz) .gt. 0. ) THEN ! { + + IF ( lvol .gt. 1 ) THEN + IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN + xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) + xdn = Min( 900., Max( hdnmn, xdn ) ) + ELSE + xdn = rho_qx + ENDIF + ELSE + xdn = rho_qx + ENDIF + + IF ( l == lr ) xdn = 1000. + + qr = a(ix,jy,kz,l) + xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + chw = a(ix,jy,kz,ln) + + IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN + xv = Min( xvmx, Max( xvmn,xv ) ) + chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + ENDIF + + zx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw + z = zx*(6./(pi*1000.))**2 + + + IF ( (z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & + & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN !{ + + zx = t0(ix,jy,kz)/((6./(pi*1000.))**2) + + nrx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/zx + IF ( infall .eq. 3 ) THEN + IF ( nrx .gt. a(ix,jy,kz,ln) ) THEN + ndbz = ndbz + 1 + IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) + ELSE + IF ( nrx .gt. a(ix,jy,kz,ln) .and. t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + IF ( nrx .lt. t1(ix,jy,kz) ) THEN + ndbz = ndbz + 1 + ELSE + nmwgt = nmwgt + 1 + IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 + ENDIF + ELSE + nnwgt = nnwgt + 1 + ENDIF + + a(ix,jy,kz,ln) = Max(Min( real(nrx), t1(ix,jy,kz) ), a(ix,jy,kz,ln) ) + ENDIF + + ELSE ! } { + IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN + IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + nmwgt = nmwgt + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + ENDIF + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + nrx = a(ix,jy,kz,ln) + + + + ENDIF ! } + + ! } + ELSE ! { + IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN + IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + nmwgt = nmwgt + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + ENDIF + ENDIF! } + + ENDDO + + + ELSEIF ( l .eq. lr .and. imurain == 3) THEN + + xdn = 1000. + + DO kz = 1,kze + IF ( t0(ix,jy,kz) .gt. 0. ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + z = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) + + IF ( z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & + & t0(ix,jy,kz) .gt. 0.0 & + & .and. t0(ix,jy,kz) .gt. z0(ix,kz,l) ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn) + chw = a(ix,jy,kz,ln) + nrx = 3.6*(rnu+2.0)*vr**2/((rnu+1.0)*t0(ix,jy,kz)) + IF ( infall .eq. 3 ) THEN + a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) + ELSEIF ( infall .eq. 4 ) THEN + a(ix,jy,kz,ln) = Max( Min( real(nrx), t1(ix,jy,kz)), a(ix,jy,kz,ln) ) + ENDIF + + ELSE + + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + + ENDIF + + ELSE + + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + + ENDIF + + + ENDDO + + ENDIF + + RETURN + + END subroutine calcnfromz1d + + +! ############################################################################## +! ############################################################################## +! +! Subroutine to calculate number concentrations from initial state that has only mixing ratio. +! N will be in #/kg, NOT #/m^3, since sedimentation is done next. +! + +! +! 10.27.2015: Added hail calculation +! + subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) + + + implicit none + + integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) + + real dn(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer lvol ! index for volume + integer infall + + + integer ix,jy,kz + double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision :: zr, zs, zh, dninv + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4 + real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 + real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) + real, parameter :: zhfac = 1./(pi*xdnh*xn0h) + real, parameter :: zrfac = 1./(pi*xdnr*xn0r) + real, parameter :: zsfac = 1./(pi*xdns*xn0s) + real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) + real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + + real xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + +! ------------------------------------------------------------------ + + + jy = 1 + + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + + g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + + IF ( imurain == 3 ) THEN + g1r = (rnu+2.0)/(rnu+1.0) + ELSE ! imurain == 1 + g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + ENDIF + + g1s = (snu+2.0)/(snu+1.0) + + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + dninv = 1./dn(ix,kz) + + ! Cloud droplets + + IF ( lnc > 1 ) THEN + IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + an(ix,jy,kz,lnc) = qccn + ENDIF + ENDIF + + ! Cloud ice + + IF ( lni > 1 ) THEN + IF ( an(ix,jy,kz,lni) <= 0.1*cxmin .and. an(ix,jy,kz,li) > qxmin(li) ) THEN + an(ix,jy,kz,lni) = an(ix,jy,kz,li)/xims + ENDIF + ENDIF + + ! rain + + IF ( lnr > 1 ) THEN + IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin(lr) ) THEN + + q = an(ix,jy,kz,lr) + + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input + + nrx = n1*g1r/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio + + ENDIF + ENDIF + + ! snow + IF ( lns > 1 ) THEN + IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin(ls) ) THEN + + q = an(ix,jy,kz,ls) + + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input + + nrx = n1*g1s/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio + + ENDIF + ENDIF + + ! graupel + + IF ( lnh > 1 ) THEN + IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN + IF ( lvh > 1 ) THEN + IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN + an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh + ENDIF + ENDIF + + q = an(ix,jy,kz,lh) + + laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input + + nrx = n1*g1h/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio + + ENDIF + ENDIF + + ! hail + + IF ( lnhl > 1 .and. lhl > 1 ) THEN + IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN + IF ( lvhl > 1 ) THEN + IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN + an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl + ENDIF + ENDIF + + q = an(ix,jy,kz,lhl) + + laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input + + nrx = n1*g1hl/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio + + ENDIF + ENDIF + + ENDDO ! ix + ENDDO ! kz + + RETURN + + END subroutine calcnfromq + +! ############################################################################## +! ############################################################################## +! +! Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio. +! N will be in #/kg, NOT #/m^3, since sedimentation is done next. +! + +! +! 10.27.2015: Added hail calculation +! + subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) + + + implicit none + + integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) from CUTEN arrays + real anold(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) + + real dn(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer lvol ! index for volume + integer infall + + + integer ix,jy,kz + double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision :: zr, zs, zh, dninv + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4 + real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 + real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) + real, parameter :: zhfac = 1./(pi*xdnh*xn0h) + real, parameter :: zrfac = 1./(pi*xdnr*xn0r) + real, parameter :: zsfac = 1./(pi*xdns*xn0s) + real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) + real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: xcms=1000.*0.523599*(2.*7.5e-6)**3 ! mks (100 micron diam solid sphere approx) + + real :: xmass,xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + +! ------------------------------------------------------------------ + + + jy = 1 + + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + + g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + + IF ( imurain == 3 ) THEN + g1r = (rnu+2.0)/(rnu+1.0) + ELSE ! imurain == 1 + g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + ENDIF + + g1s = (snu+2.0)/(snu+1.0) + + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + dninv = 1./dn(ix,kz) + + ! Cloud droplets + + IF ( lnc > 1 ) THEN +! IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + IF ( an(ix,jy,kz,lnc) > qxmin(lc) ) THEN + anold(ix,jy,kz,lnc) = anold(ix,jy,kz,lnc) + an(ix,jy,kz,lc)/xcms + ENDIF + ENDIF + + ! Cloud ice + + IF ( lni > 1 ) THEN + IF ( an(ix,jy,kz,lni) > qxmin(li) ) THEN + anold(ix,jy,kz,lni) = anold(ix,jy,kz,lni) + an(ix,jy,kz,li)/xims + ENDIF + ENDIF + + ! rain + + IF ( lnr > 1 ) THEN + IF ( an(ix,jy,kz,lr) > qxmin(lr) ) THEN ! adding rain mass from CU scheme + + IF ( .true. .or. (anold(ix,jy,kz,lr) - an(ix,jy,kz,lr)) < qxmin(lr) .or. anold(ix,jy,kz,lnr) < cxmin ) THEN + + q = an(ix,jy,kz,lr) + + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input + + nrx = n1*g1r/g0 ! number concentration for different shape parameter + + anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + nrx ! *dninv ! convert to number mixing ratio + + ELSE + ! assume mean particle mass of pre-existing snow + xmass = anold(ix,jy,kz,lr)/anold(ix,jy,kz,lnr) + anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass + ENDIF + + ENDIF + ENDIF + + ! snow + IF ( lns > 1 ) THEN + IF ( an(ix,jy,kz,ls) > qxmin(ls) ) THEN ! adding snow mass from CU scheme + + IF ( .true. .or. (anold(ix,jy,kz,ls) - an(ix,jy,kz,ls)) < qxmin(ls) .or. anold(ix,jy,kz,lns) < cxmin ) THEN + + ! assume that there was no snow before this + + q = an(ix,jy,kz,ls) + + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input + + nrx = n1*g1s/g0 ! number concentration for different shape parameter + + anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + nrx ! *dninv ! convert to number mixing ratio + + ELSE + ! assume mean particle mass of pre-existing snow + xmass = anold(ix,jy,kz,ls)/anold(ix,jy,kz,lns) + anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + an(ix,jy,kz,ls)/xmass + ENDIF + + ENDIF + ENDIF + + ! graupel + +! IF ( lnh > 1 ) THEN +! IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN +! IF ( lvh > 1 ) THEN +! IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN +! an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh +! ENDIF +! ENDIF +! +! q = an(ix,jy,kz,lh) +! +! laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope +! +! n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input +! +! nrx = n1*g1h/g0 ! number concentration for different shape parameter +! +! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio +! +! ENDIF +! ENDIF +! +! ! hail +! +! IF ( lnhl > 1 .and. lhl > 1 ) THEN +! IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN +! IF ( lvhl > 1 ) THEN +! IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN +! an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl +! ENDIF +! ENDIF +! +! q = an(ix,jy,kz,lhl) +! +! laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope +! +! n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input +! +! nrx = n1*g1hl/g0 ! number concentration for different shape parameter +! +! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio +! +! ENDIF +! ENDIF + + ENDDO ! ix + ENDDO ! kz + + RETURN + + END subroutine calcnfromcuten + +! ##################################################################### +! ##################################################################### + + SUBROUTINE calc_eff_radius & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,t1,t2,t3 & + & ,an,dn ) + + implicit none + + integer, parameter :: ng1 = 1 + integer :: nx,ny,nz,na + integer :: ng + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + + +! +! external temporary arrays +! + + real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + + + + ! local + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + +! +! declarations microphysics and for gather/scatter +! + integer nxmpb,nzmpb,nxz + integer mgs,ngs,numgs,inumgs + parameter (ngs=1) + integer ngscnt,igs(ngs),kgs(ngs) + real rho0(ngs) + + integer ix,kz,i,n, kp1 + integer :: jy, jgs + integer ixb,ixe,jyb,jye,kzb,kze + + integer itile,jtile,ktile + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + + real :: qx(ngs,lv:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: alpha(ngs,lc:lhab) + + real :: gamc1,gamc2,gami1,gami2,gams1,gams2, factor_c, factor_i, factor_s + real :: lam_c, lam_i, lam_s + integer :: il + + +! ------------------------------------------------------------------------------- + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + jy = 1 + pb(:) = 0.0 + pinit(:) = 0.0 + + gamc1 = Gamma_sp(2. + cnu) + gamc2 = 1. ! Gamma[1 + alphac] + gami1 = Gamma_sp(2. + cinu) + gami2 = 1. ! Gamma[1 + alphac] + gams1 = Gamma_sp(2. + snu) + gams2 = Gamma_sp(1. + snu) + + factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu) + factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu) + factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu) + +! +! jy = 1 ! working on a 2d slab +!! VERY IMPORTANT: SET jgs = jy + + jgs = jy + + mgs = 1 + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + rho0(mgs) = dn(ix,jy,kz) + DO il = lc,ls + qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) + cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) + ENDDO + + IF ( qx(mgs,lc) > qxmin(lc) ) THEN +! Lambda for cloud droplets + lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) + t1(ix,jy,kz) = 0.5*factor_c/lam_c + ENDIF + + IF ( qx(mgs,li) > qxmin(li) ) THEN +! Lambda for cloud ice + lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) + t2(ix,jy,kz) = 0.5*factor_i/lam_i + ENDIF + + IF ( qx(mgs,ls) > qxmin(ls) ) THEN +! Lambda for snow + lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.) + t3(ix,jy,kz) = 0.5*factor_s/lam_s + ENDIF + + + ENDDO ! ix + ENDDO ! kz + + RETURN + END SUBROUTINE calc_eff_radius + + +! ##################################################################### +! ##################################################################### + + SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & + & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt) + +!##################################################################### +! Purpose: find the amount of vapor that can be condensed to liquid +!##################################################################### + + implicit none + + integer ngs,mgs,ngscnt + + real theta2temp + + real qvex + + integer nqsat + real fqsat, cbw + + real ss1 ! 'target' supersaturation +! +! input arrays +! + real qv0(ngs), qcw1(ngscnt), pres(ngs), qwvp0(mgs) + real thetap0(ngs), theta0(ngs) + real fcqv1(ngs), felvcp(ngs), pi0(ngs) + real pk(ngs) + + real tabqvs(nqsat) +! +! Local stuff +! + + integer itertd + integer ltemq + real gamss + real theta(ngs), qvap(ngs), pqs(ngs), qcw(ngs), qwv(ngs) + real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs) + real dqcw(ngs), dqwv(ngs), dqvcnd(ngs) + real temg(ngs), temcg(ngs), thetap(ngs) + + real tfr + parameter ( tfr = 273.15 ) + +! real poo,cap +! parameter ( cap = rd/cp, poo = 1.0e+05 ) +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + pqs(mgs) = (380.0)/(pres(mgs)) + thetap(mgs) = thetap0(mgs) + theta(mgs) = thetap(mgs) + theta0(mgs) + qwvp(mgs) = qwvp0(mgs) + qvap(mgs) = max( (qwvp0(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) +! +! +! +! reset temporaries for cloud particles and vapor +! + + qwv(mgs) = max( 0.0, qvap(mgs) ) + qcw(mgs) = max( 0.0, qcw1(mgs) ) +! +! + qcwtmp(mgs) = qcw(mgs) + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) +! +! iterate adjustment +! + do itertd = 1,2 +! +! +! calculate super-saturation +! + dqcw(mgs) = 0.0 + dqwv(mgs) = ( qwv(mgs) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qcw(mgs) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qcw(mgs) + dqwv(mgs) = dqwv(mgs) + qcw(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) ) ! add to perturbation vapor +! + qcw(mgs) = qcw(mgs) + dqcw(mgs) + + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) ) + + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN +! + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) +! +! + dqcw(mgs) = dqvcnd(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) ) & + & / (pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qcw(mgs) = qcw(mgs) + dqcw(mgs) +! + END IF ! dqwv(mgs) .ge. 0. + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr +! tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qcw(mgs) = max( 0.0, qcw(mgs) ) + qwv(mgs) = max( 0.0, qvap(mgs)) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) + end do +! +! end the saturation adjustment iteration loop +! +! + qvex = Max(0.0, qcw(mgs) - qcw1(mgs) ) + + RETURN + END SUBROUTINE QVEXCESS + +! ##################################################################### +! ##################################################################### + + + + + +! +! ############################################################################## +! + SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & + & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & + & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + implicit none + + integer ngscnt,ngs0,ngs,nz +! integer infall ! whether to calculate number-weighted fall speeds + + real xv(ngs,lc:lhab) + real qx(ngs,lv:lhab) + real qxw(ngs,ls:lhab) + real cx(ngs,lc:lhab) + real vtxbar(ngs,lc:lhab,3) + real xmas(ngs,lc:lhab) + real xdn(ngs,lc:lhab) + real cdxgs(ngs,lc:lhab) + real xdia(ngs,lc:lhab,3) + real xvmn0(lc:lhab), xvmx0(lc:lhab) + real qxmin(lc:lhab) + real cdx(lc:lhab) + real alpha(ngs,lc:lhab) + + real rho0(ngs),rhovt(ngs),temcg(ngs) + real cno(lc:lhab) + real cnostmp(ngs) + + real cwc1, cimna, cimxa + real cnina(ngs) + integer kgs(ngs) + real fadvisc(ngs) + real fsw + + integer ipconc1 + integer ndebug1 + + integer, intent (in) :: itype1a,itype2a,infdo + integer, intent (in) :: ildo ! which species to do, or all if ildo=0 + + real :: axh(ngs),bxh(ngs) + real :: axhl(ngs),bxhl(ngs) + +! Local vars + + + + real swmasmx, dtmp + real cd + real cwc0 ! ,cwc1 + real :: cwch(ngscnt), cwchl(ngscnt) + real :: cwchtmp,cwchltmp,xnutmp + real pii + real cimasx,cimasn + real cwmasn,cwmasx,cwradn + real cwrad + real vr,rnux + real alp + + real ccimx + + integer mgs + + real arx,frx,vtrain,fw + real fwlo,fwhi,rfwdiff + real ar,br,cs,ds +! real gf4p5, gf4ds, gf4br, ifirst, gf1ds +! real gfcinu1, gfcinu1p47, gfcinu2p47 + real gr + real rwrad,rwdia + real mwfac + integer il + +! save gf4p5, gf4ds, gf4br, ifirst, gf1ds +! save gfcinu1, gfcinu1p47, gfcinu2p47 +! data ifirst /0/ + + real bta1,cnit + parameter ( bta1 = 0.6, cnit = 1.0e-02 ) + real x,y,tmp,del + real aax,bbx,delrho + integer :: indxr + real mwt, nwt, zwt + real, parameter :: rho00 = 1.225 + integer i + real xvbarmax + + integer l1, l2 + + +! +! set values +! +! cwmasn = 5.23e-13 ! radius of 5.0e-6 +! cwradn = 5.0e-6 +! cwmasx = 5.25e-10 ! radius of 50.0e-6 + + fwlo = 0.2 ! water fraction to start weighting toward rain fall speed + fwhi = 0.4 ! water fraction at which rain fall speed only is used + rfwdiff = 1./(fwhi - fwlo) + +! pi = 4.0*atan(1.0) + pii = piinv ! 1.0/pi + + arx = 10. + frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + + ar = 841.99666 + br = 0.8 + gr = 9.8 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab + ELSE + l1 = ildo + l2 = ildo + ENDIF + +! IF ( ifirst .eq. 0 ) THEN +! ifirst = 1 +! gf4br = gamma(4.0+br) +! gf4ds = gamma(4.0+ds) +!! gf1ds = gamma(1.0+ds) +! gf4p5 = gamma(4.0+0.5) +! gfcinu1 = gamma(cinu + 1.0) +! gfcinu1p47 = gamma(cinu + 1.47167) +! gfcinu2p47 = gamma(cinu + 2.47167) + + IF ( lh .gt. 1 ) THEN + IF ( dmuh == 1.0 ) THEN + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + ELSE + cwchtmp = 6.0*pii*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) + ENDIF + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) + ELSE + cwchltmp = 6.0*pii*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) + ENDIF + ENDIF + + IF ( ipconc .le. 5 ) THEN + IF ( lh .gt. 1 ) cwch(:) = cwchtmp + IF ( lhl .gt. 1 ) cwchl(:) = cwchltmp + ELSE + DO mgs = 1,ngscnt + + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( dmuh == 1.0 ) THEN + cwch(mgs) = ((3. + alpha(mgs,lh))*(2. + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lh) - 2.0)/3.0 + cwch(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1.)/xmu(lh) )/gamma_sp( (xnutmp + 2.)/xmu(lh) ) + ENDIF + ELSE + cwch(mgs) = cwchtmp + ENDIF + ENDIF + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchl(mgs) = ((3. + alpha(mgs,lhl))*(2. + alpha(mgs,lhl))*(1.0 + alpha(mgs,lhl)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lhl) - 2.0)/3.0 + cwchl(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1)/xmu(lhl) )/gamma_sp( (xnutmp + 2)/xmu(lhl) ) + ENDIF + ELSE + cwchl(mgs) = cwchltmp + ENDIF + ENDIF + + ENDDO + + ENDIF + + + cimasn = Min( cimas0, 6.88e-13) + cimasx = 1.0e-8 + ccimx = 5000.0e3 ! max of 5000 per liter + + cwc1 = 6.0/(pi*1000.) + cwc0 = pii ! 6.0*pii + mwfac = 6.0**(1./3.) + + + if (ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set scale diameter' +! + + +! +! cloud water variables +! ################################################################ +! +! DROPLETS +! +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cloud water variables' + + IF ( ildo == 0 .or. ildo == lc ) THEN + + do mgs = 1,ngscnt + xv(mgs,lc) = 0.0 + + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN !{ + + IF ( ipconc .ge. 2 ) THEN + IF ( cx(mgs,lc) .gt. cxmin) THEN !{ + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = Min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ENDIF + ELSE + IF ( ipconc .lt. 2 ) THEN + cx(mgs,lc) = rho0(mgs)*ccn/rho00 ! scales to local density, relative to standard air density + ENDIF + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN !{ + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & + & xdn(mgs,lc)*xvmx(lc) ) + + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 1.0e-9 ) THEN + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN + xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSE + xmas(mgs,lc) = cwmasn + xv(mgs,lc) = xmas(mgs,lc)/1000. +! do not define ccw here! it can feed back to ccn!!! cx(mgs,lc) = 0.0 ! cwnc(mgs) + ENDIF !} + ENDIF !} +! IF ( ipconc .lt. 2 ) THEN +! xmas(mgs,lc) = & +! & min( max(qx(mgs,lc)*rho0(mgs)/cwnc(mgs),cwmasn),cwmasx ) +! cx(mgs,lc) = Max(1.0,qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)) +! ELSE +! cwnc(mgs) = an(igs(mgs),jgs,kgs(mgs),lnc) +! cx(mgs,lc) = cwnc(mgs) +! ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**(1./3.) + xdia(mgs,lc,2) = xdia(mgs,lc,1)**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + cwrad = 0.5*xdia(mgs,lc,1) + IF ( fadvisc(mgs) > 0.0 ) THEN + vtxbar(mgs,lc,1) = & + & (2.0*gr*xdn(mgs,lc) *(cwrad**2)) & + & /(9.0*fadvisc(mgs)) + ELSE + vtxbar(mgs,lc,1) = 0.0 + ENDIF + + + ELSE + xmas(mgs,lc) = cwmasn + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + IF ( qx(mgs,lc) <= 0.0 ) cx(mgs,lc) = 0.0 + IF ( ipconc .le. 1 ) cx(mgs,lc) = 0.01 + xdia(mgs,lc,1) = 2.*cwradn + xdia(mgs,lc,2) = 4.*cwradn**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + vtxbar(mgs,lc,1) = 0.0 + + ENDIF !} qcw .gt. qxmin(lc) + + end do + + ENDIF + + + +! +! cloud ice variables +! columns +! +! ################################################################ +! +! CLOUD ICE +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cip' + + IF ( li .gt. 1 .and. ( ildo == 0 .or. ildo == li ) ) THEN + do mgs = 1,ngscnt + xdn(mgs,li) = 900.0 + IF ( ipconc .eq. 0 ) THEN +! cx(mgs,li) = min(cnit*exp(-temcg(mgs)*bta1),1.e+09) + cx(mgs,li) = cnina(mgs) + IF ( cimna .gt. 1.0 ) THEN + cx(mgs,li) = Max(cimna,cx(mgs,li)) + ENDIF + IF ( cimxa .gt. 1.0 ) THEN + cx(mgs,li) = Min(cimxa,cx(mgs,li)) + ENDIF +! erm 3/28/2002 + IF ( itype1a .ge. 1 .or. itype2a .ge. 1 ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) + ENDIF +! + cx(mgs,li) = max(1.0e-20,cx(mgs,li)) +! cx(mgs,li) = Min(ccimx, cx(mgs,li)) + + + ELSEIF ( ipconc .ge. 1 ) THEN + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) +! cx(mgs,li) = Max(1.0,cx(mgs,li)) + ENDIF + ENDIF + + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + xmas(mgs,li) = & + & max( qx(mgs,li)*rho0(mgs)/cx(mgs,li), cimasn ) +! & min( max(qx(mgs,li)*rho0(mgs)/cx(mgs,li),cimasn),cimasx ) + +! if ( temcg(mgs) .gt. 0.0 ) then +! xdia(mgs,li,1) = 0.0 +! else + if ( xmas(mgs,li) .gt. 0.0 ) THEN ! cimasn ) then +!c xdia(mgs,li,1) = 0.4892*(xmas(mgs,li)**(0.4554)) +! xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + +! xdia(mgs,li,1) = (132.694*5.40662/xmas(mgs,li))**(-1./2.9163) ! for inverse exponential distribution + IF ( ixtaltype == 1 ) THEN ! column + xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + xdia(mgs,li,3) = 0.1871*(xmas(mgs,li)**(0.3429)) + ELSEIF ( ixtaltype == 2 ) THEN ! disk + xdia(mgs,li,1) = 0.277823*xmas(mgs,li)**0.359971 + xdia(mgs,li,3) = 0.277823*xmas(mgs,li)**0.359971 + ENDIF + end if +! end if +! xdia(mgs,li,1) = max(xdia(mgs,li,1), 5.e-6) +! xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + + IF ( ipconc .ge. 0 ) THEN +! vtxbar(mgs,li,1) = rhovt(mgs)*49420.*40.0005/5.40662*xdia(mgs,li,1)**(1.415) ! mass-weighted +! vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + IF ( icefallopt == 1 ) THEN ! default ice fall + IF ( ixtaltype == 1 ) THEN ! column + tmp = (67056.6300748612*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p47 + vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + ELSEIF ( ixtaltype == 2 ) THEN ! disk -- but just use Ferrier (1994) snow fall speeds for now + vtxbar(mgs,li,1) = 11.9495*rhovt(mgs)*(xv(mgs,li))**(0.14) + vtxbar(mgs,li,2) = 7.02909*rhovt(mgs)*(xv(mgs,li))**(0.14) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ENDIF + + ELSEIF ( icefallopt == 2 ) THEN ! ! Ferrier ice fall speed + tmp = (82.3166*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.22117*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p22 + vtxbar(mgs,li,1) = tmp*gfcinu2p22/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ELSEIF ( icefallopt == 3 ) THEN ! ! Adjusted Ferrier (smaller exponent of 0.55 instead of 0.6635) + + tmp = (47.6273*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.18333*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p18 + vtxbar(mgs,li,1) = tmp*gfcinu2p18/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ENDIF +! vtxbar(mgs,li,1) = vtxbar(mgs,li,2)*(1.+cinu)/(1. + cinu) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) +! xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 +! vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + ELSE + xdia(mgs,li,1) = max(xdia(mgs,li,1), 10.e-6) + xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) + xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 + vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + ENDIF ! ipconc gt 3 + ELSE + xmas(mgs,li) = 1.e-13 + IF ( qx(mgs,li) <= 0.0 ) cx(mgs,li) = 0.0 + xdn(mgs,li) = 900.0 + xdia(mgs,li,1) = 1.e-7 + xdia(mgs,li,2) = (1.e-14) + xdia(mgs,li,3) = 1.e-7 + vtxbar(mgs,li,1) = 0.0 +! cicap(mgs) = 0.0 +! ciat(mgs) = 0.0 + ENDIF + + IF ( icefallfac /= 1.0 ) THEN + vtxbar(mgs,li,1) = icefallfac*vtxbar(mgs,li,1) + vtxbar(mgs,li,2) = icefallfac*vtxbar(mgs,li,2) + vtxbar(mgs,li,3) = icefallfac*vtxbar(mgs,li,3) + ENDIF + + + + end do + + ENDIF ! li .gt. 1 + + +! ################################################################ +! +! RAIN +! + +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + +! IF ( qx(mgs,lr) .gt. 10.0e-3 ) & +! & write(0,*) 'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr) + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + xvbarmax = xvmx(lr) + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(lr) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ENDIF + + IF ( xv(mgs,lr) .gt. xvbarmax ) THEN + xv(mgs,lr) = xvbarmax + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) + IF ( imurain == 3 ) THEN +! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) + xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) + ELSE ! imurain == 1, Characteristic diameter (1/lambda) + xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + ENDIF +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + +! Inverse exponential version: +! xdia(mgs,lr,1) = +! & (qx(mgs,lr)*rho0(mgs) +! & /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) + ELSE + xdia(mgs,lr,1) = & + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) + cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + end if + else + xdia(mgs,lr,1) = 1.e-9 + xdia(mgs,lr,3) = 1.e-9 + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + end if + xdia(mgs,lr,2) = xdia(mgs,lr,1)**2 +! xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 + end do + + ENDIF +! ################################################################ +! +! SNOW +! + + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + if ( ipconc .ge. 4 ) then ! + + xmas(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(Max(1.0e-9,cx(mgs,ls))) + swmasmx = 13.7e-6 +! IF ( xmas(mgs,ls) > swmasmx ) THEN +! xmas(mgs,ls) = swmasmx +! cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) +! ENDIF + + IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship + + xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) + xdn(mgs,ls) = Max( 100.0, xdn(mgs,ls) ) ! limit snow to 100. to keep other equations in line + + IF ( xdn(mgs,ls) <= 900. ) THEN + dtmp = Sqrt( xmas(mgs,ls)/0.069 ) ! diameter (meters) of mean mass particle using Cox 1998 relation (m = p d^2) + xv(mgs,ls) = 28.8887*xmas(mgs,ls)**(3./2.) + ELSE ! at small sizes, assume ice spheres + xdn(mgs,ls) = 900. + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) + dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + ELSE ! leave xdn(ls) at default value + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) + dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + xdia(mgs,ls,1) = dtmp ! (xv(mgs,ls)*cwc0*6.0)**(1./3.) + + IF ( xv(mgs,ls) .lt. xvmn(ls) .and. isnowdens == 1) THEN + xv(mgs,ls) = Max( xvmn(ls),xv(mgs,ls) ) + xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls) + cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + IF ( xv(mgs,ls) .gt. xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN + xv(mgs,ls) = Min( xvmx(ls), Max( xvmn(ls),xv(mgs,ls) ) ) + xmas(mgs,ls) = 0.106214*xv(mgs,ls)**(2./3.) + cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) + xdia(mgs,ls,1) = Sqrt( xmas(mgs,ls)/0.069 ) + ENDIF + + xdia(mgs,ls,3) = xdia(mgs,ls,1) + + ELSE + xdia(mgs,ls,1) = & + & (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25) + cx(mgs,ls) = cnostmp(mgs)*xdia(mgs,ls,1) + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + xdia(mgs,ls,3) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + end if + else + xdia(mgs,ls,1) = 1.e-9 + xdia(mgs,ls,3) = 1.e-9 + cx(mgs,ls) = 0.0 + + IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship + xdn(mgs,ls) = 90. + ENDIF + + end if + xdia(mgs,ls,2) = xdia(mgs,ls,1)**2 +! swdia3(mgs) = xdia(mgs,ls,2)*xdia(mgs,ls,1) +! xmas(mgs,ls) = xdn(mgs,ls)*(pi/6.)*swdia3(mgs) + end do + + ENDIF ! ls .gt 1 +! +! +! ################################################################ +! +! GRAUPEL +! + + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + if ( ipconc .ge. 5 ) then + + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*Max(1.0e-9,cx(mgs,lh))) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) + + IF ( xv(mgs,lh) .lt. xvmn(lh) .or. xv(mgs,lh) .gt. xvmx(lh) ) THEN + xv(mgs,lh) = Min( xvmx(lh), Max( xvmn(lh),xv(mgs,lh) ) ) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) + cx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xmas(mgs,lh)) + ENDIF + + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*pii)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuh == 1.0 ) THEN + xdia(mgs,lh,1) = cwch(mgs)*xdia(mgs,lh,3) + ELSE + xdia(mgs,lh,1) = (xv(mgs,lh)*cwch(mgs))**(1./3.) + ENDIF + + ELSE + xdia(mgs,lh,1) = & + & (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25) + cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) + xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) + xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + else + xdia(mgs,lh,1) = 1.e-9 + xdia(mgs,lh,3) = 1.e-9 + end if + xdia(mgs,lh,2) = xdia(mgs,lh,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + + ENDIF + +! +! ################################################################ +! +! HAIL +! + + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then + if ( ipconc .ge. 5 ) then + + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*Max(1.0e-9,cx(mgs,lhl))) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xmas(mgs,lhl),qx(mgs,lhl) + + IF ( xv(mgs,lhl) .lt. xvmn(lhl) .or. xv(mgs,lhl) .gt. xvmx(lhl) ) THEN + xv(mgs,lhl) = Min( xvmx(lhl), Max( xvmn(lhl),xv(mgs,lhl) ) ) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) + cx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xmas(mgs,lhl)) + ENDIF + + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuhl == 1.0 ) THEN + xdia(mgs,lhl,1) = cwchl(mgs)*xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = (xv(mgs,lhl)*cwchl(mgs))**(1./3.) + ENDIF + +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = & + & (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25) + cx(mgs,lhl) = cno(lhl)*xdia(mgs,lhl,1) + xv(mgs,lhl) = Max(xvmn(lhl), rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ) + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) + end if + else + xdia(mgs,lhl,1) = 1.e-9 + xdia(mgs,lhl,3) = 1.e-9 + end if + xdia(mgs,lhl,2) = xdia(mgs,lhl,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + + ENDIF +! +! +! +! Set terminal velocities... +! also set drag coefficients (moved to start of subroutine) +! +! cdx(lr) = 0.60 +! cdx(lh) = 0.45 +! cdx(lhl) = 0.45 +! cdx(lf) = 0.45 +! cdx(lgh) = 0.60 +! cdx(lgm) = 0.80 +! cdx(lgl) = 0.80 +! cdx(lir) = 2.00 +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set terminal velocities' +! +! +! ################################################################ +! +! RAIN +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + IF ( ipconc .lt. 3 ) THEN + vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs) +! write(91,*) 'vtxbar: ',vtxbar(mgs,lr,1),mgs,gf4br,xdia(mgs,lr,1),rhovt(mgs) + ELSE + + IF ( imurain == 1 ) THEN ! DSD of Diameter + + ! using functional form of arx*(1 - Exp(-frx*diameter) ), with arx = arx = 10. + ! and frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + ! Similar form as in Atlas et al. (1973), who had 9.65 - 10.3*Exp[-600 * d] + + + alp = alpha(mgs,lr) + + vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted + + IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ! number weighted + ELSE + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + + IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ! z-weighted + ELSE + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + +! write(91,*) 'setvt: alp,vn,vm,vz = ',alp,vtxbar(mgs,lr,2), vtxbar(mgs,lr,1), vtxbar(mgs,lr,3),alpha(mgs,lr) + + ELSEIF ( imurain == 3 ) THEN ! DSD of Volume + + IF ( lzr < 1 ) THEN ! not 3-moment rain + rwdia = Min( xdia(mgs,lr,1), 8.0e-3 ) + + vtxbar(mgs,lr,1) = rhovt(mgs)*6.0*pii*( 0.04771 + 3788.0*rwdia - & + & 1.105e6*rwdia**2 + 1.412e8*rwdia**3 - 6.527e9*rwdia**4) + + IF ( infdo .ge. 1 ) THEN + IF ( rssflg >= 1 ) THEN + vtxbar(mgs,lr,2) = (0.09112 + 2714.0*rwdia - 4.872e5*rwdia**2 + & + & 4.495e7*rwdia**3 - 1.626e9*rwdia**4)*rhovt(mgs) + ELSE + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + ENDIF + + IF ( infdo .ge. 2 ) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)*( & + & 0.0911229 + & + & 9246.494*(rwdia) - & + & 3.2839926e6*(rwdia**2) + & + & 4.944093e8*(rwdia**3) - & + & 2.631718e10*(rwdia**4) ) + ENDIF + + ELSE ! 3-moment rain, gamma-volume + + vr = xv(mgs,lr) + rnux = alpha(mgs,lr) + + IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag + vtxbar(mgs,lr,2) = rhovt(mgs)* & + & (((1. + rnux)/vr)**(-1.333333)* & + & (0.0911229*((1. + rnux)/vr)**1.333333*Gamma_sp(1. + rnux) + & + & (5430.3131*(1. + rnux)*Gamma_sp(4./3. + rnux))/ & + & vr - 1.0732802e6*((1. + rnux)/vr)**0.6666667* & + & Gamma_sp(1.666667 + rnux) + & + & 8.584110982429507e7*((1. + rnux)/vr)**(1./3.)* & + & Gamma_sp(2. + rnux) - & + & 2.3303765697228556e9*Gamma_sp(7./3. + rnux)))/ & + & Gamma_sp(1. + rnux) + ENDIF + +! mass-weighted + vtxbar(mgs,lr,1) = rhovt(mgs)* & + & (0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(2. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma_sp(2.333333333333333 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666*vr**0.6666666666666666* & + & Gamma_sp(2.6666666666666667 + rnux) + & + & 8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(3 + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma_sp(3.333333333333333 + rnux))/ & + & ((1 + rnux)**2.333333333333333*Gamma_sp(1 + rnux)) + + IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + + IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)* & + & ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(3. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma_sp(3.3333333333333335 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666* & + & vr**0.6666666666666666*Gamma_sp(3.6666666666666665 + rnux) + & + & 8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(4. + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma_sp(4.333333333333333 + rnux)))/ & + & ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma_sp(1 + rnux)) + +! write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) + + ELSEIF (infdo .ge. 2) THEN ! No size-sorting, set Z-weighted fall speed to mass-weighted + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + + + ENDIF + ENDIF ! imurain + +! IF ( rwrad*mwfac .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,1) = 20.1*Sqrt(100.*rwrad*mwfac)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,1) = 80.0e2*rwrad*rhovt(mgs)*mwfac +! ENDIF +! IF ( rwrad .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,2) = 20.1*Sqrt(100.*rwrad)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,2) = 80.0e2*rwrad*rhovt(mgs) +! ENDIF + ENDIF ! ipconc + else ! qr < qrmin + vtxbar(mgs,lr,1) = 0.0 + vtxbar(mgs,lr,2) = 0.0 + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set rain vt' + + ENDIF +! +! ################################################################ +! +! SNOW !Zrnic et al. (1993) +! + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + IF ( ipconc .ge. 4 ) THEN + if ( mixedphase .and. qsvtmod ) then + else + IF ( isnowfall == 1 ) THEN + ! original (Zrnic et al. 1993) + vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + IF ( isnowdens == 1 ) THEN + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14) + ELSE + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) + ENDIF + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,1) = 50.092*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + + IF(Abs(sssflg) >= 1) THEN + IF ( isnowfall == 1 ) THEN + vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + IF ( isnowdens == 1 ) THEN + vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1) + ELSE + vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1) + ENDIF + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,2) = 21.6147*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + ELSE + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDIF + IF ( infdo >= 2 ) THEN + IF ( isnowfall == 1 ) THEN + vtxbar(mgs,ls,3) = 6.12217*rhovt(mgs)*(xv(mgs,ls))**(1./12.) ! Zrnic et al 93 + ELSEIF ( isnowfall == 2 ) THEN + vtxbar(mgs,ls,3) = 13.3436*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! Ferrier 94 + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,3) = 61.0914*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + ENDIF + + IF ( sssflg < 0 .and. temcg(mgs) > Abs(sssflg) ) THEN ! above a given temperature, effectively turn off size sorting + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1) + ENDIF + + endif + ELSE ! single-moment: + vtxbar(mgs,ls,1) = (cs*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDIF + else + vtxbar(mgs,ls,1) = 0.0 + end if + + IF ( snowfallfac /= 1.0 ) THEN + vtxbar(mgs,ls,1) = snowfallfac*vtxbar(mgs,ls,1) + vtxbar(mgs,ls,2) = snowfallfac*vtxbar(mgs,ls,2) + vtxbar(mgs,ls,3) = snowfallfac*vtxbar(mgs,ls,3) + ENDIF + + + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set snow vt' + + ENDIF ! ls .gt. 1 +! +! +! ################################################################ +! +! GRAUPEL !Wisner et al. (1972) +! + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + + do mgs = 1,ngscnt + vtxbar(mgs,lh,1) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + cd = cdx(lh) + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lh)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axh(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxh(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + + + ELSE + axh(mgs) = mmgraupvt(indxr,2) + bxh(mgs) = mmgraupvt(indxr,3) + ENDIF + + aax = axh(mgs) + bbx = bxh(mgs) + + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + + ELSEIF ( icdx <= 0 ) THEN ! + aax = ax(lh) + bbx = bx(lh) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSE + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ENDIF + + cdxgs(mgs,lh) = cd + IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN +! axh(mgs) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lh)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + axh(mgs) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + bxh(mgs) = 0.5 + vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axh(mgs) * Sqrt(xdia(mgs,lh,1)) +! vtxbar(mgs,lh,1) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + ELSE + IF ( icdx /= 6 ) bbx = bx(lh) + tmp = 4. + alpha(mgs,lh) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 4. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! aax = Max( 1.0, Min(2.0, (xdn(mgs,lh)/400.) ) ) +! vtxbar(mgs,lh,1) = rhovt(mgs)*aax*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + + IF ( icdx > 0 .and. icdx /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y + axh(mgs) = aax + bxh(mgs) = bbx + ELSEIF (icdx == 6 ) THEN + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y + ELSE ! icdx < 0 + axh(mgs) = ax(lh) + bxh(mgs) = bx(lh) + vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + ENDIF + +! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) + ENDIF + + IF ( lwsm6 .and. ipconc == 0 ) THEN +! vtxbar(mgs,lh,1) = (330.*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs) + ENDIF + + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lh .gt. 1 +! +! +! ################################################################ +! +! HAIL +! + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + vtxbar(mgs,lhl,1) = 0.0 + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then + + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lhl)/rho_qh)**(2./3.) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lhl)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axhl(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxhl(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + + + ELSE + axhl(mgs) = mmgraupvt(indxr,2) + bxhl(mgs) = mmgraupvt(indxr,3) + ENDIF + + aax = axhl(mgs) + bbx = bxhl(mgs) + + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + + ELSE +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) +! cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ENDIF + + cdxgs(mgs,lhl) = cd + + IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 .and. icdxhl /= 6) THEN +! axhl(mgs) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lhl)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + axhl(mgs) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + bxhl(mgs) = 0.5 + vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axhl(mgs) * Sqrt(xdia(mgs,lhl,1)) + ELSE + IF ( icdxhl /= 6 ) bbx = bx(lhl) + tmp = 4. + alpha(mgs,lhl) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 4. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( icdxhl > 0 .and. icdxhl /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y + axhl(mgs) = aax + bxhl(mgs) = bbx + ELSEIF ( icdxhl == 6 ) THEN + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y + ELSE + axhl(mgs) = ax(lhl) + bxhl(mgs) = bx(lhl) + vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y + ENDIF + +! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) + ENDIF + + + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lhl .gt. 1 + + + IF ( infdo .ge. 1 ) THEN + +! DO il = lc,lhab +! IF ( il .ne. lr ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + IF ( li .gt. 1 ) THEN +! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) +! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) + +! test print stuff... +! IF ( xdia(mgs,li,1) .gt. 200.e-6 ) THEN +! tmp = (xv(mgs,li)*cwc0)**(1./3.) +! x = rhovt(mgs)*49420.*40.0005/5.40662*tmp**(1.415) +! y = rhovt(mgs)*49420.*1.25447*tmp**(1.415) +! write(6,*) 'Ice fall: ',vtxbar(mgs,li,1),x,y,tmp,xdia(mgs,li,1) +! ENDIF + ENDIF +! vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDDO + + IF ( lg .gt. lr ) THEN + + DO il = lg,lhab + IF ( ildo == 0 .or. ildo == il ) THEN + + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN ! DTD: added flag for size-sorting + + ! DTD: allow for setting of number-weighted and z-weighted fall speeds to the mass-weighted value, + ! effectively turning off size-sorting + + IF ( il .eq. lh ) THEN ! { + + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axh(mgs) + bbx = bxh(mgs) + ELSEIF ( icdx <= 0 ) THEN ! + aax = ax(lh) + bbx = bx(lh) + ENDIF + + ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN + + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl == 5 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) + cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axhl(mgs) + bbx = bxhl(mgs) + ENDIF + + ENDIF ! } + + IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and. & + ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! { + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cd*rho0(mgs)) ) + + ELSE + IF ( il == lh .and. icdx /= 6 ) bbx = bx(il) + IF ( il == lhl .and. icdxhl /= 6 ) bbx = bx(il) + tmp = 1. + alpha(mgs,il) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + alpha(mgs,il) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( il .eq. lh .or. il .eq. lhl) THEN ! { + IF ( ( il==lh .and. icdx > 0 ) ) THEN + IF ( icdx /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y + ELSE ! (icdx == 6 ) THEN + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF + + ELSEIF ( ( il==lhl .and. icdxhl > 0 ) ) THEN + IF ( icdxhl /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y + ELSE ! ( icdxhl == 6 ) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF + ELSE ! get here if il==lh and icdx < 0 -- or -- il==lhl and icdxhl < 0 + aax = ax(il) + vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y + ENDIF + +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* & +! & x)/y +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(ax(il)*xdia(mgs,il,1)**bx(il)* & +! & x)/y + IF ( infdo .ge. 2 ) THEN ! Z-weighted + + tmp = 7. + alpha(mgs,il) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 7. + alpha(mgs,il) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(xdia(mgs,il,1) )**bbx * & + & x)/y +! & Gamma(7.0 + alpha(mgs,il) + bbx))/Gamma(7. + alpha(mgs,il)) + IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & + .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN + write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y + ! call commasmpi_abort() + ENDIF +! & (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt3' + + ELSE ! hail + vtxbar(mgs,il,2) = & + & rhovt(mgs)*(ax(il)*xdia(mgs,il,1)**bx(il)* & + & x)/y + + IF ( infdo .ge. 2 ) THEN ! Z-weighted + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(1.0/xdia(mgs,il,1) )**(- bbx)* & + & Gamma_sp(7.0 + alpha(mgs,il) + bbx))/Gamma_sp(7. + alpha(mgs,il)) +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt4' + + ENDIF ! } +! & Gamma_sp(1.0 + dnu(il) + 0.6)/Gamma_sp(1. + dnu(il)) + ENDIF ! } + +! IF ( infdo .ge. 2 ) THEN ! Z-weighted +! vtxbar(mgs,il,3) = rhovt(mgs)* & +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) +! ENDIF + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'setvt: ',qx(mgs,il),xdia(mgs,il,1),xdia(mgs,il,3),dnu(il),ax(il),bx(il) +! ENDIF + ELSEIF ( (il .eq. lh .and. hssflg == 0) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 0) ) THEN ! no size-sorting for graupel or hail + vtxbar(mgs,il,2) = vtxbar(mgs,il,1) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) + ELSE ! not lh or lhl + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cdx(il)*rho0(mgs)) ) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5' + + + ENDIF + ELSE ! qx < qxmin + vtxbar(mgs,il,2) = 0.0 + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt6' + + ENDIF + ENDDO ! mgs + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt7' + + ENDIF + ENDDO ! il + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt8' + + ENDIF ! lg .gt. 1 + +! ENDIF +! ENDDO + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt9' + +! DO mgs = 1,ngscnt +! IF ( qx(mgs,lr) > qxmin(lr) ) THEN +! write(0,*) 'setvt2: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) +! ENDIF +! ENDDO + + ENDIF ! infdo .ge. 1 + + IF ( lh > 0 .and. graupelfallfac /= 1.0 ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lh,1) = graupelfallfac*vtxbar(mgs,lh,1) + vtxbar(mgs,lh,2) = graupelfallfac*vtxbar(mgs,lh,2) + vtxbar(mgs,lh,3) = graupelfallfac*vtxbar(mgs,lh,3) + axh(mgs) = graupelfallfac*axh(mgs) + ENDDO + ENDIF + + IF ( lhl > 0 .and. hailfallfac /= 1.0 ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lhl,1) = hailfallfac*vtxbar(mgs,lhl,1) + vtxbar(mgs,lhl,2) = hailfallfac*vtxbar(mgs,lhl,2) + vtxbar(mgs,lhl,3) = hailfallfac*vtxbar(mgs,lhl,3) + axhl(mgs) = hailfallfac*axhl(mgs) + ENDDO + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: END OF ROUTINE' + +!############ SETVTZ ############################ + + RETURN + END SUBROUTINE setvtz +!-------------------------------------------------------------------------- + +! +! ############################################################################## + +! +! subroutine to calculate fall speeds of hydrometeors +! + + subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & + & xvt, rhovtzx, & + & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,ildo,timesetvt) + +! 12.16.2005: .F version use in transitional SWM model +! +! 10.10.2003: Added cimn and cimx to setting for cci and cip. +! +! TO DO LIST: +! +! need to set up values for: +! : cipdia,cidia,cwdia,cwmas,vtwbar, +! : rho0,temcg,cip,cci +! +! and need to put fallspeed values in cwvt etc. +! + + implicit none + integer ng1 + parameter(ng1 = 1) + + integer, intent(in) :: ixcol ! which column to return + integer, intent(in) :: ildo + + integer nx,ny,nz,nor,norz,ngt,jgs,na + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real dn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real dtp,dtz1 + + real :: rhovtzx(nz,nx) + + integer ndebugzf + parameter (ndebugzf = 0) + + integer ix,jy,kz,i,j,k,il + integer infdo +! +! + real xvt(nz+1,nx,3,lc:lhab) ! 1=mass-weighted, 2=number-weighted + + real qxmin(lc:lhab) + real xdn0(lc:lhab) + real xvmn(lc:lhab), xvmx(lc:lhab) + double precision,optional :: timesetvt + + integer :: ngs + integer :: ngscnt,mgs,ipconc0 +! parameter ( ngs=200 ) + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: cdxgs(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + +! +! drag coefficients +! + real cdx(lc:lhab) +! +! Fixed intercept values for single moment scheme +! + real cno(lc:lhab) + + real cwccn0,cwmasn,cwmasx,cwradn +! real cwc0 + + integer nxmpb,nzmpb,nxz,numgs,inumgs + integer kstag + parameter (kstag=1) + + integer igs(ngs),kgs(ngs) + + real rho0(ngs),temcg(ngs) + + real temg(ngs) + + real rhovt(ngs) + + real cwnc(ngs),cinc(ngs) + real fadvisc(ngs),cwdia(ngs),cipmas(ngs) + +! real cimasn,cimasx, + real :: cnina(ngs),cimas(ngs) + + real :: cnostmp(ngs) + +! real pii +! +! +! general constants for microphysics +! + +! +! Miscellaneous +! + + logical flag + logical ldoliq + + + real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp + + real vtmax + real xvbarmax + + integer l1, l2 + + double precision :: dpt1, dpt2 + + +!----------------------------------------------------------------------------- +! MPI LOCAL VARIABLES + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + + logical :: debug_mpi = .false. + + + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: ENTERED SUBROUTINE" + +! ##################################################################### +! BEGIN EXECUTABLE +! ##################################################################### +! + +! constants +! + + ldoliq = .false. + IF ( ls .gt. 1 ) THEN + DO il = ls,lhab + ldoliq = ldoliq .or. ( lliq(il) .gt. 1 ) + ENDDO + ENDIF + +! poo = 1.0e+05 +! cp608 = 0.608 +! cp = 1004.0 +! cv = 717.0 +! dnz00 = 1.225 +! rho00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds +! cs = 12.42 +! ds = 0.42 +! pi = 4.0*atan(1.0) +! pii = piinv ! 1./pi +! pid4 = pi/4.0 +! qccrit = 2.0e-03 +! qscrit = 6.0e-04 +! cwc0 = pii + +! +! +! general constants for microphysics +! + +! +! ci constants in mks units +! +! cimasn = 6.88e-13 +! cimasx = 1.0e-8 +! +! Set terminal velocities... +! also set drag coefficients +! + jy = jgs + nxmpb = ixcol + nzmpb = 1 + nxz = 1*nz +! ngs = nz + numgs = 1 + + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab + ELSE + l1 = ildo + l2 = ildo + ENDIF + + + do inumgs = 1,numgs + ngscnt = 0 + + + do kz = nzmpb,nz + do ix = ixcol,ixcol + flag = .false. + + + DO il = l1,l2 + flag = flag .or. ( an(ix,jy,kz,il) .gt. qxmin(il) ) + ENDDO + + if ( flag ) then +! load temp quantities + + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if + end do !!ix + nxmpb = 1 + end do !! kz + +! if ( jy .eq. (ny-jstag) ) iend = 1 + + 1100 continue + + if ( ngscnt .eq. 0 ) go to 9998 +! +! set temporaries for microphysics variables +! + + +! +! Reconstruct various quantities +! + do mgs = 1,ngscnt + + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhovt(mgs) = rhovtzx(kgs(mgs),ixcol) ! Sqrt(rho00/rho0(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + + +! + end do +! +! only need fadvisc for + IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) + end do + ENDIF + + IF ( ipconc .eq. 0 ) THEN + do mgs = 1,ngscnt + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + end do + ENDIF + + + IF ( ildo > 0 ) THEN + vtxbar(:,ildo,:) = 0.0 + ELSE + vtxbar(:,:,:) = 0.0 + ENDIF + +! do mgs = 1,ngscnt +! qx(mgs,lv) = max(an(igs(mgs),jy,kgs(mgs),lv), 0.0) +! ENDDO + DO il = l1,l2 + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + end do + + cnostmp(:) = cno(ls) + IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF + + +! +! set concentrations +! + cx(:,:) = 0.0 + + if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + end do + end if + if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) +! IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! ELSE +! cx(mgs,lr) = Max( 0.0, cx(mgs,lr) ) +! ENDIF + end do + end if + if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) +! IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! ELSE +! cx(mgs,ls) = Max( 0.0, cx(mgs,ls) ) +! ENDIF + end do + end if + + if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then + do mgs = 1,ngscnt + + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) +! IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! ELSE +! cx(mgs,lh) = Max( 0.0, cx(mgs,lh) ) +! ENDIF + + end do + ENDIF + + if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then + do mgs = 1,ngscnt + + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) +! IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN +! cx(mgs,lhl) = 0.0 +! ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN +! qx(mgs,lhl) = 0.0 +! ELSE +! cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) ) +! ENDIF + + end do + end if + + do mgs = 1,ngscnt + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) +! IF ( ls .gt. 1 .and. lvs .eq. 0 ) xdn(mgs,ls) = xdn0(ls) +! IF ( lh .gt. 1 .and. lvh .eq. 0 ) xdn(mgs,lh) = xdn0(lh) + IF ( li .gt. 1 ) xdn(mgs,li) = xdn0(li) + IF ( ls .gt. 1 ) xdn(mgs,ls) = xdn0(ls) + IF ( lh .gt. 1 ) xdn(mgs,lh) = xdn0(lh) + IF ( lhl .gt. 1 ) xdn(mgs,lhl) = xdn0(lhl) + end do + +! +! Set mean particle volume +! + IF ( ldovol .and. (ildo == 0 .or. ildo >= li ) ) THEN + + vx(:,:) = 0.0 + + DO il = l1,l2 + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + IF ( vx(mgs,il) .gt. rho0(mgs)*qxmin(il)*1.e-3 .and. qx(mgs,il) .gt. qxmin(il) ) THEN + xdn(mgs,il) = Min( xdnmx(il), Max( xdnmn(il), rho0(mgs)*qx(mgs,il)/vx(mgs,il) ) ) + ENDIF + ENDDO + + ENDIF + + ENDDO + + ENDIF + + DO il = lg,lhab + DO mgs = 1,ngscnt + alpha(mgs,il) = dnu(il) + ENDDO + ENDDO + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + + + + + + +! +! Set density +! + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' +! + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + +! +! put fall speeds into the x-z arrays +! + DO il = l1,l2 + do mgs = 1,ngscnt + + vtmax = 150.0 + + + IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & + & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN + + + + vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) + + ENDIF + + + IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & + & vtxbar(mgs,il,3) .gt. vtmax ) THEN + + vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) + vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) + +! call commasmpi_abort() + ENDIF + + + xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1) + xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2) + IF ( infdo .ge. 2 ) THEN + xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3) + ELSE + xvt(kgs(mgs),igs(mgs),3,il) = 0.0 + ENDIF + +! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il) + + enddo + ENDDO + + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' + + + + 9998 continue + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: DONE WITH LOOP' + + if ( kz .gt. nz-1 ) then + go to 1200 + else + nzmpb = kz + end if + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB' + + end do !! inumgs + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NXMPB' + + 1200 continue + + +! ENDDO ! ix +! ENDDO ! kz + + + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE" + + + RETURN + END subroutine ziegfall1d + +! ##################################################################### +! ##################################################################### + + +! ##################################################################### +! ##################################################################### + +! ############################################################################## + subroutine radardd02(nx,ny,nz,nor,na,an,temk, & + & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit) +! +! 11.13.2005: Changed values of indices for reordering of lip +! +! 07.13.2005: Fixed an error where cnoh was being used for graupel and frozen drops +! +! 01.24.2005: add ice crystal reflectivity using parameterization of +! Heymsfield (JAS, 1977). Could also try Ferrier for this, too. +! +! 09.28.2002 Test alterations for dry ice following Ferrier (1994) +! for equivalent melted diameter reflectivity. +! Converted to Fortran by ERM. +! +!Date: Tue, 21 Nov 2000 10:13:36 -0600 (CST) +!From: Matthew Gilmore +! +!PRO RF_SPEC ; Computes Radar Reflectivity +!COMMON MAINB, data, x1d, y1d, z1d, iconst, rconst, labels, nx, ny, nz, dshft +! +!;MODIFICATION HISTORY +!; 5/99 -Svelta Veleva introduces variable dielf (const_ki_x) as a (weak) +!; function of density. This leads to slight modification of dielf such +!; that the snow reflectivity is slightly increased - not a big effect. +!; This is believed to be more accurate than assuming the dielectric +!; constant for snow is the same as for hail in previous versions. +! +!;On 6/13/99 I added the VIL computation (k=0 in vil array) +!;On 6/15/99 I removed the number concentration dependencies as a function +!; of temperature (only use for ferrier!) +!;On 6/15/99 I added the Composite reflectivity (k=1 in VIL array) +!;On 6/15/99 I added the Severe Hail Index computation (k=2 in vil array) +!; +!; 6/99 - Veleva and Seo argue that since graupel is more similar to +!; snow (in number conc and size density) than it is to hail, we +!; should not weight wetted graupel with the .95 exponent correction +!; factor as in the case of hail. An if-statement checks the size +!; density for wet hail/graupel and treats them appropriately. +!; +!; 6/22/99 - Added function to compute height of max rf and 40 dbz echo top +!; Also added vilqr which is the model vertical integrated liquid only +!; using qr. Will need to check...does not seem consistent with vilZ +!; + + + implicit none + + character(LEN=15), parameter :: microp = 'ZVD' + integer nx,ny,nz,nor,na,ngt + integer nzdbz ! how many levels actually to process + + integer ng1,n10 + integer iunit + integer, parameter :: printyn = 0 + + parameter( ng1 = 1 ) + + real cnoh0t,hwdn1t + integer ke_diag + integer ipconc + real vr + + + integer imapz,mzdist + + integer vzflag + integer, parameter :: norz = 3 + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air density +! real gt(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,ngt) + real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air temperature (kelvin) + real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! reflectivity + real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4) + +! real g,rgas,eta,inveta + real cr1, cr2 , hwdnsq,swdnsq + real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc + real reflectmin, kw_sq + real const_ki_sn, const_ki_h, ki_sq_sn + real ki_sq_h, dielf_sn, dielf_h + real pi + logical ltest + +! Other data arrays + real gtmp (nx,nz) + real dtmp (nx,nz) + real tmp + + real*8 dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x + + integer i,j,k,ix,jy,kz,ihcnt + + real*8 xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc + real*8 dadr + real dbzmax,dbzmin + parameter ( dbzmin = 0 ) + + real cnow,cnoi,cnoip,cnoir,cnor,cnos + real cnogl,cnogm,cnogh,cnof,cnoh,cnohl + + real swdn, rwdn ,hwdn,gldn,gmdn,ghdn,fwdn,hldn + real swdn0 + + real rwdnmx,cwdnmx,cidnmx,xidnmx,swdnmx,gldnmx,gmdnmx + real ghdnmx,fwdnmx,hwdnmx,hldnmx + real rwdnmn,cwdnmn,cidnmn,xidnmn,swdnmn,gldnmn,gmdnmn + real ghdnmn,fwdnmn,hwdnmn,hldnmn + + real gldnsq,gmdnsq,ghdnsq,fwdnsq,hldnsq + + real dadgl,dadgm,dadgh,dadhl,dadf + real zgldryc,zglwetc,zgmdryc, zgmwetc,zghdryc,zghwetc + real zhldryc,zhlwetc,zfdryc,zfwetc + + real dielf_gl,dielf_gm,dielf_gh,dielf_hl,dielf_fw + + integer imx,jmx,kmx + + real swdia,gldia,gmdia,ghdia,fwdia,hwdia,hldia + + real csw,cgl,cgm,cgh,cfw,chw,chl + real xvs,xvgl,xvgm,xvgh,xvf,xvh,xvhl + + real cwc0 + integer izieg + integer ice10 + real rhos + parameter ( rhos = 0.1 ) + + real qxw,qxw1 ! temp value for liquid water on ice mixing ratio + real :: dnsnow + real qh + + real, parameter :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwradn = 5.0e-6 ! minimum radius + + real cwnccn(nz) + + real :: vzsnow, vzrain, vzgraupel, vzhail + real :: ksq + real :: dtp + + +! ######################################################################### + + vzflag = 0 + + izieg = 0 + ice10 = 0 +! g=9.806 ! g: gravity constant +! rgas=287.04 ! rgas: gas constant for dry air +! rcp=rgas/cp ! rcp: gamma constant +! eta=0.622 +! inveta = 1./eta +! rcpinv = 1./rcp +! cpr=cp/rgas +! cvr=cv/rgas + pi = 4.0*ATan(1.) + cwc0 = piinv ! 1./pi ! 6.0/pi + + cnoh = cnoh0t + hwdn = hwdn1t + + rwdn = 1000.0 + swdn = 100.0 + + qrmin = 1.0e-05 + qsmin = 1.0e-06 + qhmin = 1.0e-05 + +! +! default slope intercepts +! + cnow = 1.0e+08 + cnoi = 1.0e+08 + cnoip = 1.0e+08 + cnoir = 1.0e+08 + cnor = 8.0e+06 + cnos = 8.0e+06 + cnogl = 4.0e+05 + cnogm = 4.0e+05 + cnogh = 4.0e+05 + cnof = 4.0e+05 + cnohl = 1.0e+03 + + + imx = 1 + jmx = 1 + kmx = 1 + i = 1 + + + IF ( microp(1:4) .eq. 'ZIEG' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + +! write(0,*) 'Set reflectivity for ZIEG' + izieg = 1 + + hwdn = hwdn1t ! 500. + + + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF + + ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + + izieg = 1 + + swdn0 = swdn + + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF +! write(*,*) 'radardbz: ',db(1,1,1),temk(1,1,1),an(1,1,1,lr),an(1,1,1,ls),an(1,1,1,lh) + + + ENDIF + + +! cdx(lr) = 0.60 +! +! IF ( lh > 1 ) THEN +! cdx(lh) = 0.8 ! 1.0 ! 0.45 +! cdx(ls) = 2.00 +! ENDIF +! +! IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 +! +! xvmn(lc) = xvcmn +! xvmn(lr) = xvrmn +! +! xvmx(lc) = xvcmx +! xvmx(lr) = xvrmx +! +! IF ( lh > 1 ) THEN +! xvmn(ls) = xvsmn +! xvmn(lh) = xvhmn +! xvmx(ls) = xvsmx +! xvmx(lh) = xvhmx +! ENDIF +! +! IF ( lhl .gt. 1 ) THEN +! xvmn(lhl) = xvhlmn +! xvmx(lhl) = xvhlmx +! ENDIF +! +! xdnmx(lr) = 1000.0 +! xdnmx(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmx(li) = 917.0 +! xdnmx(ls) = 300.0 +! xdnmx(lh) = 900.0 +! ENDIF +! IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 +!! +! xdnmn(:) = 900.0 +! +! xdnmn(lr) = 1000.0 +! xdnmn(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmn(li) = 100.0 +! xdnmn(ls) = 100.0 +! xdnmn(lh) = hdnmn +! ENDIF +! IF ( lhl .gt. 1 ) xdnmn(lhl) = 500.0 +! +! xdn0(:) = 900.0 +! +! xdn0(lc) = 1000.0 +! xdn0(lr) = 1000.0 +! IF ( lh > 1 ) THEN +! xdn0(li) = 900.0 +! xdn0(ls) = 100.0 ! 100.0 +! xdn0(lh) = hwdn1t ! (0.5)*(xdnmn(lh)+xdnmx(lh)) +! ENDIF +! IF ( lhl .gt. 1 ) xdn0(lhl) = 800.0 + +! +! slope intercepts +! +! cnow = 1.0e+08 +! cnoi = 1.0e+08 +! cnoip = 1.0e+08 +! cnoir = 1.0e+08 +! cnor = 8.0e+06 +! cnos = 8.0e+06 +! cnogl = 4.0e+05 +! cnogm = 4.0e+05 +! cnogh = 4.0e+05 +! cnof = 4.0e+05 +!c cnoh = 4.0e+04 +! cnohl = 1.0e+03 +! +! +! density maximums and minimums +! + rwdnmx = 1000.0 + cwdnmx = 1000.0 + cidnmx = 917.0 + xidnmx = 917.0 + swdnmx = 200.0 + gldnmx = 400.0 + gmdnmx = 600.0 + ghdnmx = 800.0 + fwdnmx = 900.0 + hwdnmx = 900.0 + hldnmx = 900.0 +! + rwdnmn = 1000.0 + cwdnmn = 1000.0 + xidnmn = 001.0 + cidnmn = 001.0 + swdnmn = 001.0 + gldnmn = 200.0 + gmdnmn = 400.0 + ghdnmn = 600.0 + fwdnmn = 700.0 + hwdnmn = 700.0 + hldnmn = 900.0 + + + gldn = (0.5)*(gldnmn+gldnmx) ! 300. + gmdn = (0.5)*(gmdnmn+gmdnmx) ! 500. + ghdn = (0.5)*(ghdnmn+ghdnmx) ! 700. + fwdn = (0.5)*(fwdnmn+fwdnmx) ! 800. + hldn = (0.5)*(hldnmn+hldnmx) ! 900. + + + cr1 = 7.2e+20 + cr2 = 7.295e+19 + hwdnsq = hwdn**2 + swdnsq = swdn**2 + rwdnsq = rwdn**2 + + gldnsq = gldn**2 + gmdnsq = gmdn**2 + ghdnsq = ghdn**2 + fwdnsq = fwdn**2 + hldnsq = hldn**2 + + dhmin = 0.005 + tfr = 273.16 + tfrh = tfr - 8.0 + zrc = cr1*cnor + reflectmin = 0.0 + kw_sq = 0.93 + dbzmax = dbzmin + + ihcnt=0 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Dielectric Factor - Formulas implemented by Svetla Veleva +! following Battan, "Radar Meteorology" - p. 40 +! The result of these calculations is that the dielf numerator (ki_sq) without +! the density ratio is .2116 for hail if using 917 density and .25 for +! snow if using 220 density. +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + const_ki_sn = 0.5 - (0.5-0.46)/(917.-220.)*(swdn-220.) + const_ki_h = 0.5 - (0.5-0.46)/(917.-220.)*(hwdn-220.) + ki_sq_sn = (swdnsq/rwdnsq) * const_ki_sn**2 + ki_sq_h = (hwdnsq/rwdnsq) * const_ki_h**2 + dielf_sn = ki_sq_sn / kw_sq + dielf_h = ki_sq_h / kw_sq + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the next line if you want to hardwire dielf for dry hail for both dry +! snow and dry hail. +! This would be equivalent to what Straka had originally. (i.e, .21/.93) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + dielf_sn = (swdnsq/rwdnsq)*.21/ kw_sq + dielf_h = (hwdnsq/rwdnsq)*.21/ kw_sq + + dielf_gl = (gldnsq/rwdnsq)*.21/ kw_sq + dielf_gm = (gmdnsq/rwdnsq)*.21/ kw_sq + dielf_gh = (ghdnsq/rwdnsq)*.21/ kw_sq + dielf_hl = (hldnsq/rwdnsq)*.21/ kw_sq + dielf_fw = (fwdnsq/rwdnsq)*.21/ kw_sq + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Notes on dielectric factors - from Eun-Kyoung Seo +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! constants for both snow and hail would be (x=s,h)..... +! xwdnsq/rwdnsq *0.21/kw_sq ! Straka/Smith - the original +! xwdnsq/rwdnsq *0.224 ! Ferrier - for particle sizes in equiv. drop diam +! xwdnsq/rwdnsq *0.176/kw_sq ! =0.189 in Smith - for particle sizes in equiv +! ice spheres +! xwdnsq/rwdnsq *0.208/kw_sq ! Smith 1984 - for particle sizes in equiv melted drop diameter +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! VIL algorithm constants +! Ztop = 10.**(56./10) !56 dbz is the max rf used by WATADS in cell vil + + +! Hail detection algorithm constants +! ZL = 40. +! ZU = 50. +! Ho = 3400. !WATADS Defaults +! Hm20 = 6200. !WATADS Defaults + +! DO kz = 1,Min(nzdbz,nz-1) + + DO jy=1,1 + + DO kz = 1,ke_diag ! nz + + DO ix=1,nx + dbz(ix,jy,kz) = 0.0 + + vzsnow = 0.0 + vzrain = 0.0 + vzgraupel = 0.0 + vzhail = 0.0 + + dtmph = 0.0 + dtmps = 0.0 + dtmphl = 0.0 + dtmpr = 0.0 + dadr = (db(ix,jy,kz)/(pi*rwdn*cnor))**(0.25) +!----------------------------------------------------------------------- +! Compute Rain Radar Reflectivity +!----------------------------------------------------------------------- + + dtmp(ix,kz) = 0.0 + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,lr) .ge. qrmin ) THEN + IF ( ipconc .le. 2 ) THEN + gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) + dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 + ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN + IF ( imurain == 3 ) THEN + vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) + dtmp(ix,kz) = 3.6e18*(rnu+2.)*an(ix,jy,kz,lnr)*vr**2/(rnu+1.) + ELSE ! imurain == 1 + g1 = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lr))**2/an(ix,jy,kz,lnr) + ze =1.e18*zx*(6./(pi*1000.))**2 ! note: using 1000. here for water density + dtmp(ix,kz) = ze + ENDIF + ENDIF + dtmpr = dtmp(ix,kz) + ENDIF + +!----------------------------------------------------------------------- +! Compute snow and graupel reflectivity +! +! Lou modified to look at parcel temperature rather than base state +!----------------------------------------------------------------------- + + IF( lhab .gt. lr ) THEN + +! qs2d = reform(data[*,*,k,10],[nx*ny]) +! qh2d = reform(data[*,*,k,11],[nx*ny]) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Straka GEMS microphysics +! (Sam 1-d version modified by L Wicker does not use this) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ;xcnoh = cnoh*exp(-0.025*(temp-tfr)) +! ;xcnos = cnos*exp(-0.038*(temp-tfr)) +! ;good = where(temp GT tfr, n_elements) +! ;IF n_elements NE 0 THEN xcnoh(good) = cnoh*exp(-0.075*(temp(good)-tfr)) +! ;IF n_elements NE 0 THEN xcnos(good) = cnos*exp(-0.088*(temp(good)-tfr)) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Ferrier micro with No=No(T) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ; NOSE = -.15 +! ; NOGE = .0 +! ; xcnoh = cnoh*(1.>exp(NOGE*(temp-tfr)) ) +! ; xcnos = cnos*(1.>exp(NOSE*(temp-tfr)) ) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the following lines if Nos and Noh are constant +! (As in Svetla version of Ferrier, GCE Tao, and SAM 1-d) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + xcnoh = cnoh + xcnos = cnos + +! +! Temporary fix for predicted number concentration -- need a +! more appropriate reflectivity equation! +! +! IF ( an(ix,jy,kz,lns) .lt. 0.1 ) THEN +! swdia = (xvrmn*cwc0)**(1./3.) +! xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvrmn*swdn*swdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! swdia = +! > (an(ix,jy,kz,ls)*db(ix,jy,kz) +! > /(pi*swdn*an(ix,jy,kz,lns)))**(1./3.) +! +! xcnos = an(ix,jy,kz,lns)/swdia +! ENDIF + + IF ( ls .gt. 1 ) THEN ! { + + IF ( lvs .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + swdn = db(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + swdn = Min( 300., Max( 100., swdn ) ) + ELSE + swdn = swdn0 + ENDIF + + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { + + xvs = db(ix,jy,kz)*an(ix,jy,kz,ls)/ & + & (swdn*Max(1.0e-3,an(ix,jy,kz,lns))) + IF ( xvs .lt. xvsmn .or. xvs .gt. xvsmx ) THEN + xvs = Min( xvsmx, Max( xvsmn,xvs ) ) + csw = db(ix,jy,kz)*an(ix,jy,kz,ls)/(xvs*swdn) + ENDIF + + swdia = (xvs*cwc0)**(1./3.) + xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvs*swdn*swdia) + + ENDIF ! } + ENDIF ! } + +! IF ( an(ix,jy,kz,lnh) .lt. 0.1 ) THEN +! hwdia = (xvrmn*cwc0)**(1./3.) +! xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvrmn*hwdn*hwdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! hwdia = +! > (an(ix,jy,kz,lh)*db(ix,jy,kz) +! > /(pi*hwdn*an(ix,jy,kz,lnh)))**(1./3.) +! +! xcnoh = an(ix,jy,kz,lnh)/hwdia +! ENDIF + + IF ( lh .gt. 1 ) THEN ! { + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( hdnmn, hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF + ELSE + hwdn = hwdn1t + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { + + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/ & + & (hwdn*Max(1.0e-3,an(ix,jy,kz,lnh))) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF + + hwdia = (xvh*cwc0)**(1./3.) + xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvh*hwdn*hwdia) + + ENDIF ! } ipconc .ge. 5 + + ENDIF ! } + + dadh = 0.0 + dadhl = 0.0 + dads = 0.0 + IF ( xcnoh .gt. 0.0 ) THEN + dadh = ( db(ix,jy,kz) /(pi*hwdn*xcnoh) )**(.25) + zhdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnoh ! dielf_h*cr1*xcnoh ! SV - equiv formula as before but + ! ratio of densities included in + ! dielf_h rather than here following + ! Battan. + ELSE + dadh = 0.0 + zhdryc = 0.0 + ENDIF + + IF ( xcnos .gt. 0.0 ) THEN + dads = ( db(ix,jy,kz) /(pi*swdn*xcnos) )**(.25) + zsdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnos ! dielf_sn*cr1*xcnos ! SV - similar change as above + ELSE + dads = 0.0 + zsdryc = 0.0 + ENDIF + zhwetc = zhdryc ! cr1*xcnoh !Hail/graupel version with .95 power bug removed + zswetc = zsdryc ! cr1*xcnos +! +! snow contribution +! + IF ( ls .gt. 1 ) THEN + + gtmp(ix,kz) = 0.0 + qxw = 0.0 + qxw1 = 0.0 + dtmps = 0.0 + IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN !{ + IF ( ipconc .ge. 4 ) THEN ! (Ferrier 94) !{ + + if (lsw .gt. 1) THEN + qxw = an(ix,jy,kz,lsw) + qxw1 = 0.0 + ELSEIF ( iusewetsnow == 1 .and. temk(ix,jy,kz) .gt. tfr+1. .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) & + & .and. an(ix,jy,kz,lr) > qsmin) THEN + qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr)) + qxw1 = qxw + ENDIF + + vr = xvs ! db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) +! gtmp(ix,kz) = 3.6e18*(0.243*rhos**2/0.93)*(snu+2.)*an(ix,jy,kz,lns)*vr**2/(snu+1.) + + ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere + IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN + IF ( .true. ) THEN +! IF ( qxw > qsmin ) THEN ! old version +! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & +! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + + ENDIF + + ENDIF + +! tmp = Min(1.0,1.e3*(an(ix,jy,kz,ls))*db(ix,jy,kz)) +! gtmp(ix,kz) = Max( 1.0*gtmp(ix,kz), 750.0*(tmp)**1.98) + dtmps = gtmp(ix,kz) + dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz) + ELSE ! }{ single-moment snow: + gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25) + + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN !{ + dtmps = zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ELSE + dtmp(ix,kz) = dtmp(ix,kz) + & + & zswetc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ENDIF + ENDIF !} + ENDIF !} + + ENDIF !} + + ENDIF + + +! +! ice crystal contribution (Heymsfield, 1977, JAS) +! + IF ( li .gt. 1 .and. idbzci .ne. 0 ) THEN + + IF ( idbzci == 1 .and. lni > 0 ) THEN + ! assume spherical ice with density of 900 for dbz calc + IF ( an(ix,jy,kz,li) > qxmin(li) .and. an(ix,jy,kz,lni) > 1.0 ) THEN + vr = db(ix,jy,kz)*an(ix,jy,kz,li)/(900.*an(ix,jy,kz,lni)) + dtmp(ix,kz) = dtmp(ix,kz) + & + & 0.224*3.6e18*(cinu+2.)*an(ix,jy,kz,lni)*vr**2/(cinu+1.)*(900./1000.)**2 + ENDIF + + ELSEIF ( idbzci == 2 ) THEN +! +! ice crystal contribution (Heymsfield, 1977, JAS) +! + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,li) .ge. 0.1e-3 ) THEN + gtmp(ix,kz) = Min(1.0,1.e3*(an(ix,jy,kz,li))*db(ix,jy,kz)) + dtmp(ix,kz) = dtmp(ix,kz) + 750.0*(gtmp(ix,kz))**1.98 + ENDIF + + ENDIF + + ENDIF + +! +! graupel/hail contribution +! + IF ( lh .gt. 1 ) THEN ! { + gtmp(ix,kz) = 0.0 + dtmph = 0.0 + qxw = 0.0 + + IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN + + ltest = .false. + + IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN + + IF ( lvh .gt. 1 ) THEN + + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( 100., hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF + + ENDIF + + chw = an(ix,jy,kz,lnh) + IF ( chw .gt. 0.0 ) THEN ! (Ferrier 94) + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*Max(1.0e-3,chw)) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF + + qh = an(ix,jy,kz,lh) + + IF ( lhw .gt. 1 ) THEN + IF ( iusewetgraupel .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhw) + ELSEIF ( iusewetgraupel .eq. 2 ) THEN + IF ( hwdn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhw) + ENDIF + ENDIF + ELSEIF ( iusewetgraupel .eq. 3 ) THEN + IF ( hwdn .lt. 300. .and. temk(ix,jy,kz) > tfr .and. an(ix,jy,kz,lr) > qhmin ) THEN + qxw = Min( an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw + ENDIF + ELSEIF ( iusewetgraupel == 4 .and. temk(ix,jy,kz) .gt. tfr+0.25 .and. an(ix,jy,kz,lh) > an(ix,jy,kz,lr) & + & .and. an(ix,jy,kz,lr) > qhmin) THEN + qxw = Min(0.5*an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw + + ENDIF + + IF ( lzh .gt. 1 ) THEN + ELSE + g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw +! ze = 0.224*1.e18*zx*(6./(pi*1000.))**2 + zx = g1*db(ix,jy,kz)**2*( 0.224*qh + 0.776*qxw)*qh/chw + ze =1.e18*zx*(6./(pi*1000.))**2 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmph = ze + ENDIF + + ENDIF + + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF + + ELSE + + dtmph = 0.0 + + IF ( an(ix,jy,kz,lh) .ge. qhmin ) THEN + gtmp(ix,kz) = dadh*an(ix,jy,kz,lh)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN + dtmph = zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) +! +! & (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF + ENDIF + + + + ENDIF + + + ENDIF ! } + + ENDIF ! na .gt. 5 + + + IF ( izieg .ge. 1 .and. lhl .gt. 1 ) THEN + + hldn = 900.0 + gtmp(ix,kz) = 0.0 + dtmphl = 0.0 + qxw = 0.0 + + + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hldn = db(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + hldn = Min( 900., Max( 300., hldn ) ) + ELSE + hldn = 900. + ENDIF + ELSE + hldn = rho_qhl + ENDIF + + + IF ( ipconc .ge. 5 ) THEN + + ltest = .false. + + IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ + chl = an(ix,jy,kz,lnhl) + IF ( chl .gt. 0.0 ) THEN !{ + xvhl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/ & + & (hldn*Max(1.0e-9,an(ix,jy,kz,lnhl))) + IF ( xvhl .lt. xvhlmn .or. xvhl .gt. xvhlmx ) THEN ! { + xvhl = Min( xvhlmx, Max( xvhlmn,xvhl ) ) + chl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvhl*hldn) + ! do not update state in dbz calc. ! an(ix,jy,kz,lnhl) = chl + ENDIF ! } + + IF ( lhlw .gt. 1 ) THEN + IF ( iusewethail .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhlw) + ELSEIF ( iusewethail .eq. 2 ) THEN + IF ( hldn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhlw) + ENDIF + ENDIF + ENDIF + + IF ( lzhl .gt. 1 ) THEN !{ + ELSE !} + + g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lhl) + 0.776*qxw)*an(ix,jy,kz,lhl)/chl +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lhl))**2/chl + ze = 1.e18*zx*(6./(pi*1000.))**2 ! 3/28/2016 removed extra factor of 0.224 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmphl = ze + + ENDIF !} + ENDIF!} + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF + + + ELSE + + + IF ( an(ix,jy,kz,lhl) .ge. qhlmin ) THEN ! { + dadhl = ( db(ix,jy,kz) /(pi*hldn*cnohl) )**(.25) + gtmp(ix,kz) = dadhl*an(ix,jy,kz,lhl)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN ! { + + zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl + + dtmphl = zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) + + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) +! +! : (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF ! } + + ENDIF ! } + + ENDIF ! ipconc .ge. 5 + + + ENDIF ! izieg .ge. 1 .and. lhl .gt. 1 + + + + IF ( dtmp(ix,kz) .gt. 0.0 ) THEN + dbz(ix,jy,kz) = Max(dbzmin, 10.0*Log10(dtmp(ix,kz)) ) + + IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN + dbzmax = Max(dbzmax,dbz(ix,jy,kz)) + imx = ix + jmx = jy + kmx = kz + ENDIF + ELSE + dbz(ix,jy,kz) = dbzmin + IF ( lh > 1 .and. lhl > 1) THEN + IF ( an(ix,jy,kz,lh) > 1.0e-3 ) THEN + write(0,*) 'radardbz: qr,qh,qhl = ',an(ix,jy,kz,lr), an(ix,jy,kz,lh),an(ix,jy,kz,lhl) + write(0,*) 'radardbz: dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + + IF ( lzh>1 .and. lzhl>1 ) write(0,*) 'radardbz: zh, zhl = ',an(ix,jy,kz,lzh),an(ix,jy,kz,lzhl) + ENDIF + ENDIF + ENDIF + +! IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and. +! & dbz(ix,jy,kz) .le. 0.0 ) THEN +! write(0,*) 'dbz = ',dbz(ix,jy,kz) +! write(0,*) 'Hail intercept: ',xcnoh,ix,kz +! write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) +! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) +! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph +! ENDIF + IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN +! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN +! write(0,*) 'my_rank = ',my_rank + write(0,*) 'ix,jy,kz = ',ix,jy,kz + write(0,*) 'dbz = ',dbz(ix,jy,kz) + write(0,*) 'db, zhdryc = ',db(ix,jy,kz),zhdryc + write(0,*) 'Hail intercept: ',xcnoh,ix,kz + write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) + write(0,*) 'graupel density hwdn = ',hwdn + write(0,*) 'rain q: ',an(ix,jy,kz,lr) + write(0,*) 'ice q: ',an(ix,jy,kz,li) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lhl): ',an(ix,jy,kz,lhl) + IF (ipconc .ge. 3 ) write(0,*) 'rain c: ',an(ix,jy,kz,lnr) + IF ( lzr > 1 ) write(0,*) 'rain Z: ',an(ix,jy,kz,lzr) + IF ( ipconc .ge. 5 ) THEN + write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lnhl): ',an(ix,jy,kz,lnhl) + IF ( lzhl .gt. 1 ) THEN + write(0,*) 'Hail (lzhl): ',an(ix,jy,kz,lzhl) + write(0,*) 'chl,xvhl,dhl = ',chl,xvhl,(xvhl*6./3.14159)**(1./3.) + write(0,*) 'xvhlmn,xvhlmx = ',xvhlmn,xvhlmx + ENDIF + ENDIF + write(0,*) 'chw,xvh = ', chw,xvh + write(0,*) 'dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + write(0,*) 'dtmpr = ',dtmpr + write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) + IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN + write(0,*) 'dbz out of bounds! STOP!' +! STOP + ENDIF + ENDIF + + + ENDDO ! ix + ENDDO ! kz + ENDDO ! jy + + + + +! write(0,*) 'na,lr = ',na,lr + IF ( printyn .eq. 1 ) THEN +! IF ( dbzmax .gt. dbzmin ) THEN + write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx + write(iunit,*) 'qrw = ',an(imx,jmx,kmx,lr) + + IF ( lh .gt. 1 ) THEN + write(iunit,*) 'qi = ',an(imx,jmx,kmx,li) + write(iunit,*) 'qsw = ',an(imx,jmx,kmx,ls) + write(iunit,*) 'qhw = ',an(imx,jmx,kmx,lh) + IF ( lhl .gt. 1 ) write(iunit,*) 'qhl = ',an(imx,jmx,kmx,lhl) + ENDIF + + + ENDIF + + + RETURN + END subroutine radardd02 + + +! ############################################################################## +! ############################################################################## + + +! ##################################################################### +! ##################################################################### +! +! Subroutine for explicit cloud condensation and droplet nucleation +! + SUBROUTINE NUCOND & + & (nx,ny,nz,na,jyslab & + & ,nor,norz,dtp,nxi & + & ,dz3d & + & ,t0,t9 & + & ,an,dn,p2 & + & ,pn,w & + & ,axtra,io_flag & + & ,ssfilt,t00,t77,flag_qndrop & + & ) + + + implicit none + + integer :: nx,ny,nz,na,nxi + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + logical :: flag_qndrop + + integer, parameter :: ng1 = 1 + + +! +! external temporary arrays +! + real t00(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t8(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t9(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real qv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real ssfilt(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + ! local + + + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + logical :: io_flag + + real :: dv + +! +! declarations microphysics and for gather/scatter +! + real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. + real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. + integer nxmpb,nzmpb,nxz + integer mgs,ngs,numgs,inumgs + parameter (ngs=500) + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs) + integer nsvcnt + + integer ix,kz,i,n, kp1, km1 + integer :: jy, jgs + integer ixb,ixe,jyb,jye,kzb,kze + + integer itile,jtile,ktile + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + +! +! Variables for Ziegler warm rain microphysics +! + + + real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) + real ccncuf(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real :: ssmax(ngs) = 0.0 ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real ventrx(ngs) + real ventrxn(ngs) + real volb, t2s + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler + + real ec0, ex1, ft, rhoinv(ngs) + + real chw, g1, rd1 + + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super + real tmpmx, fw, qctmp + real x,y,del,r,alpr + double precision :: vent1,vent2 + real g1palp + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation + + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real dcrit + real cn(ngs), cnuf(ngs) + real :: ccwmax + + integer ltemq + + integer il + + real es(ngs) ! ss(ngs), +! real eis(ngs) + real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs) + real, parameter :: ssfcut = 4.0 + real ssfjp1(ngs),ssfjm1(ngs) + real ssfip1(ngs),ssfim1(ngs) + + real supcb, supmx + parameter (supcb=0.5,supmx=238.0) + real r2dxm, r2dym, r2dzm + real dssdz, dssdy, dssdx +! real tqvcon + real epsi,d + parameter (epsi = 0.622, d = 0.266) + real r1,qevap ! ,slv + + real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc + real ctmp, ccwtmp + real f5, qvs0 ! Kessler condensation factor + real :: t0p1, t0p3 + real qvex + +! real, dimension(ngs) :: temp, tempc, elv, elf, els, pqs, theta, temg, temcg + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs) + real temp(ngs),tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) ! ,tembzg(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real felv(ngs),felf(ngs),fels(ngs) + real felvcp(ngs),felvpi(ngs) + real gamw(ngs),gams(ngs) ! qciavl(ngs), + real tsqr(ngs),ssi(ngs),ssw(ngs) + real cc3(ngs),cqv1(ngs),cqv2(ngs) + real qcwtmp(ngs),qtmp + + real fvent(ngs) !,fraci(ngs),fracl(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) + real fschm(ngs),fpndl(ngs) + + real pres(ngs),pipert(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs) + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real qss0(ngs) + real fcqv1(ngs) + real wvel(ngs),wvelkm1(ngs) + + real wvdf(ngs),tka(ngs) + real advisc(ngs) + + real rwvent(ngs) + + + real :: qx(ngs,lv:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + + + logical zerocx(lc:lqmx) + + logical :: lprint + + integer, parameter :: iunit = 0 + + real :: frac, hwdn, tmpg + + real :: cvm,cpm,rmm + + real, parameter :: rovcp = rd/cp + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure + + integer :: kstag + + integer :: count + + +! ------------------------------------------------------------------------------- + itile = nxi + jtile = ny + ktile = nz + ixend = nxi + jyend = ny + kzend = nz + nxend = nxi + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73) + + jy = 1 + kstag = 0 + pb(:) = 0.0 + pinit(:) = 0.0 + + IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200 + +! +! Ziegler nucleation +! + +! ssfilt(:,:,:) = 0.0 + ssmx = 0 + count = 0 + + do kz = 1,nz-kstag + do ix = 1,nxi + + temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz) + t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1 = t00(ix,jy,kz)*tabqvs(ltemq) + + IF ( c1 > 0. ) THEN + ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values + ENDIF + + ENDDO + ENDDO + + +! +! jy = 1 ! working on a 2d slab +!! VERY IMPORTANT: SET jgs = jy + + jgs = jy + +! +!..Gather microphysics +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Gather stage' + + nxmpb = 1 + nzmpb = 1 + nxz = nxi*nz + numgs = nxz/ngs + 1 + + + do 2000 inumgs = 1,numgs + + ngscnt = 0 + + + kzb = nzmpb + kze = nz-kstag + ! if (kzbeg .le. nzmpb .and. kzend .gt. nzmpb) kzb = nzmpb + + ixb = nxmpb + ixe = itile + + do kz = kzb,kze + do ix = nxmpb,nxi + + pqs(1) = 380.0/(pn(ix,jy,kz) + pb(kz)) + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) + + temcg(1) = temg(1) - tfr + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) + + qss(1) = qvs(1) + + + if ( temg(1) .lt. tfr ) then + end if +! + if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxsupersat ) .and. & + & ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) & + & )) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 2100 + end if + + end do !ix + + nxmpb = 1 + end do !kz +! if ( jy .eq. (ny-jstag) ) iend = 1 + 2100 continue + + if ( ngscnt .eq. 0 ) go to 29998 + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8' + +! write(0,*) 'NUCOND: dbg = 8, ngscnt,ssmx = ',ngscnt,ssmx + + + qx(:,:) = 0.0 + cx(:,:) = 0.0 + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + +! +! define temporaries for state variables to be used in calculations +! + DO mgs = 1,ngscnt + qx(mgs,lv) = an(igs(mgs),jy,kgs(mgs),lv) + DO il = lc,lhab + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + + qcwtmp(mgs) = qx(mgs,lc) + + + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) ! + thetap(mgs) = 0.0 + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = qx(mgs,lv) + qwvp(mgs) = qx(mgs,lv) - qv0(mgs) + + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/rho0(mgs)) + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) +! pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) +! + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + es(mgs) = 6.1078e2*tabqvs(ltemq) + qss(mgs) = qvs(mgs) + + + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) +! + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + ELSE ! equation set 2 in cm1 + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + IF ( eqtset == 2 ) THEN + + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + + ELSE + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + ENDIF + + ENDIF + + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 +! + fels(mgs) = felv(mgs) + felf(mgs) + fcqv1(mgs) = 4098.0258*felv(mgs)*cpi + + wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pb(kgs(mgs)) + pn(igs(mgs),jgs,kgs(mgs)))) ! diffusivity of water vapor, Hall and Pruppacher (76) + advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) ! dynamic viscosity (SMT; see Beard & Pruppacher 71) + tka(mgs) = tka0*advisc(mgs)/advisc1 ! thermal conductivity + + + ENDDO + + + +! +! load concentrations +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) + cwnccn(mgs) = cwccn*rho0(mgs)/rho00 ! background ccn count + cn(mgs) = 0.0 + IF ( lss > 1 ) THEN + ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) + ELSE + ssmax(mgs) = 0.0 + ENDIF + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = cwnccn(mgs) + ENDIF + IF ( lccnuf .gt. 1 ) THEN + ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf) + ELSE + ccncuf(mgs) = 0.0 + ENDIF + cnuf(mgs) = 0.0 + IF ( lccna > 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ! predicted count of activated ccn + ELSE + IF ( lccn > 1 ) THEN + ccna(mgs) = cwnccn(mgs) - ccnc(mgs) ! diagnose activated ccn as background value - remaining unactivated ccn + ELSE + ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + end do + end if + +! cnuc(1:ngscnt) = cwccn*rho0(mgs)/rho00*(1. - renucfrac) + ccnc(1:ngscnt)*renucfrac + DO mgs = 1,ngscnt + ! default value of renucfrac is 0.0 + IF ( irenuc /= 6 ) THEN + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + ELSE + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac + ENDIF + IF ( renucfrac >= 0.999 ) THEN + IF ( temg(mgs) < 265. ) THEN + IF ( qx(mgs,lc) > 10.*qxmin(lc) .and. w(igs(mgs),jgs,kgs(mgs)) > 2.0 ) THEN + cnuc(mgs) = 0.0 ! Min(cnuc(mgs), 0.5*cx(mgs,lc) ) ! Hack to reduce nucleation at low temp in updraft when ccn are not predicted + ELSE + cnuc(mgs) = 0.1*cnuc(mgs) + ENDIF + ENDIF + ENDIF + ENDDO + +! Set density +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set density' + + do mgs = 1,ngscnt + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + end do + + ventrx(:) = ventr + ventrxn(:) = ventrn + + + +! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit + ssmx = 0.0 + DO mgs = 1,ngscnt + + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,Max(1,kgs(mgs)-1))) + + ssat0(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) + ssf(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) +! ssmx = Max( ssmx, ssf(mgs) ) + + + ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) + ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) + + + ENDDO + + + +! +! cloud water variables +! + + if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables' + + do mgs = 1,ngscnt + xv(mgs,lc) = 0.0 + IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & + & xdn(mgs,lc)*xvmx(lc) ) + + cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. cxmin ) THEN +! xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 +! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSE + xmas(mgs,lc) = cwmasn + ENDIF + ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + + + end do +! +! rain +! + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-9,cx(mgs,lr))) +! parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 ) ! mks + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN + xv(mgs,lr) = xvmx(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) + IF ( imurain == 3 ) THEN +! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) + xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) + ELSE ! imurain == 1, Characteristic diameter (1/lambda) + xdia(mgs,lr,1) = (6.*piinv*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + ENDIF +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + +! Inverse exponential version: +! xdia(mgs,lr,1) = +! > (qx(mgs,lr)*rho0(mgs) +! > /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) + ELSE + xdia(mgs,lr,1) = & + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + end if + else + xdia(mgs,lr,1) = 1.e-9 +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + end if + + end do + + +! +! Ventilation coefficients + + do mgs = 1,ngscnt + + + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) + + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) + + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pres(mgs))) + + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) + + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + + end do +! +! +! Ziegler nucleation +! +! +! cloud evaporation, condensation, and nucleation +! sqsat -> qss(mgs) + + DO mgs=1,ngscnt + dcloud = 0.0 + IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxsupersat ) THEN + CYCLE + ENDIF + + IF( ssat0(mgs) .GT. 0. .OR. ssf(mgs) .GT. 0. ) GO TO 620 +!6/4 IF( qvap(mgs) .EQ. qss(mgs) ) GO TO 631 +! +!.... EVAPORATION. QV IS LESS THAN qss(mgs). +!.... EVAPORATE CLOUD FIRST +! + IF ( qx(mgs,lc) .LE. 0. ) GO TO 631 +!.... CLOUD EVAPORATION. +! convert input 'cp' to cgs + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ & + & (cp*(temg(mgs) - cbw)**2)) + QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) + + + IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 + qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) + thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp + ENDIF + qx(mgs,lc) = 0. + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ENDIF + ENDIF + cx(mgs,lc) = 0. + ELSE + qctmp = qx(mgs,lc) + qwvp(mgs) = qwvp(mgs) + QEVAP + qx(mgs,lc) = qx(mgs,lc) - QEVAP + IF ( qx(mgs,lc) .le. 0. ) THEN + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ENDIF + ENDIF + cx(mgs,lc) = 0. + ELSE + tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ENDIF + cx(mgs,lc) = cx(mgs,lc) - tmp + ENDIF + thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp + ENDIF + + ENDIF + + GO TO 631 + + + 620 CONTINUE + +!.... CLOUD CONDENSATION + + IF ( qx(mgs,lc) .GT. qxmin(lc) .and. cx(mgs,lc) .ge. 1. ) THEN + + + +! ac1 = xdn(mgs,lc)*elv(kgs(mgs))**2*epsi/ +! : (tka(kgs(mgs))*rw*temg(mgs)**2) +! took out xdn factor because it cancels later... + ac1 = felv(mgs)**2/(tka(mgs)*rw*temg(mgs)**2) + + +! bc = xdn(mgs,lc)*rw*temg(mgs)/ +! : (epsi*wvdf(kgs(mgs))*es(mgs)) +! took out xdn factor because it cancels later... + bc = rw*temg(mgs)/(wvdf(mgs)*es(mgs)) + +! bs = rho0(mgs)*((rd*temg(mgs)/(epsi*es(mgs)))+ +! : (epsi*elv(kgs(mgs))**2/(pres(mgs)*temg(mgs)*cp))) + +! taus = Min(dtp, xdn(mgs,lc)*rho0(mgs)*(ac1+bc)/ +! : (4*pi*0.89298*BS*0.5*xdia(mgs,lc,1)*cx(mgs,lc)*xdn(mgs,lc))) + +! + IF ( ssf(mgs) .gt. 0.0 .or. ssat0(mgs) .gt. 0.0 ) THEN + IF ( ny .le. 2 ) THEN +! write(0,*) 'undershoot: ',ssf(mgs), +! : ( (qx(mgs,lv) - dcloud)/c1 - 1.0)*100. + ENDIF + + + + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + + IF ( xdia(mgs,lc,1) .le. 0.0 ) THEN + xmas(mgs,lc) = cwmasn + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + ENDIF + d1 = (1./(ac1 + bc))*4.0*pi*ventc & + & *0.5*xdia(mgs,lc,1)*cx(mgs,lc)*rhoinv(mgs) + + ELSE + d1 = 0.0 + ENDIF + + IF ( rcond .eq. 2 .and. qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > 1.e-9 ) THEN + IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + + ELSE ! imurain == 1 + + IF ( iferwisventr == 1 ) THEN + alpr = Min(alpharmax,alpha(mgs,lr) ) +! alpr = alpha(mgs,lr) + x = 1. + alpr + + tmp = 1 + alpr + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpr + 0.5*bx(lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + +! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK +! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK + vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula) + vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) + + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + + ENDIF ! iferwisventr + + ENDIF ! imurain + + d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & + & *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs) + ELSE + d1r = 0.0 + ENDIF + + + e1 = felvcp(mgs)/(pi0(mgs)) + f1 = pk(mgs) ! (pres(mgs)/poo)**cap + +! +! fifth trial to see what happens: +! + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + ltemq1 = ltemq + temp1 = temg(mgs) + p380 = 380.0/pres(mgs) + +! taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) ) +! nc = NInt(dtp/Min(1.0,0.5*taus)) +! dtcon = dtp/float(nc) + ss1 = qx(mgs,lv)/qvs(mgs) + ss2 = ss1 + temp2 = temp1 + qv1 = qx(mgs,lv) + qvs1 = qvs(mgs) + qis1 = qis(mgs) + dt1 = 0.0 + + +! dtcon = Max(dtcon,0.2) +! nc = Nint(dtp/dtcon) + + ltemq1 = ltemq +! want to start out with a small time step to handle the steep slope +! and fast changes, then can switch to a larger step (dtcon2) for the +! rest of the big time step. +! base the initial time step (dtcon1) on the slope (delta) + IF ( Abs(ss1 - 1.0) .gt. 1.e-5 ) THEN + delta = 0.5*(qv1-qvs1)/(d1*(ss1 - 1.0)) + ELSE + delta = 0.1*dtp + ENDIF +! delta is the extrapolated time to get halfway from qv1 to qvs1 +! want at least 5 time steps to the halfway point, so multiply by 0.2 +! for the initial time step + dtcon1 = Min(0.05,0.2*delta) + nc = Max(5,2*NInt( (dtp-4.0*dtcon1)/delta)) + dtcon2 = (dtp-4.0*dtcon1)/nc + + n = 1 + dt1 = 0.0 + nc = 0 + dqc = 0.0 + dqr = 0.0 + dqi = 0.0 + dqs = 0.0 + dqvii = 0.0 + dqvis = 0.0 + + RK2c: DO WHILE ( dt1 .lt. dtp ) + nc = 0 + IF ( n .le. 4 ) THEN + dtcon = dtcon1 + ELSE + dtcon = dtcon2 + ENDIF + 609 dqv = -(ss1 - 1.)*d1*dtcon + dqvr = -(ss1 - 1.)*d1r*dtcon + dtemp = -0.5*e1*f1*(dqv + dqvr) +! write(0,*) 'RK2c dqv1 = ',dqv +! calculate midpoint values: + ! ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5) + + ! 7.6.2016: Test full calc of ltemq + ltemq1m = (temp1+dtemp-163.15)*fqsati+1.5 + ltemq1m = Min( nqsat, Max(1,ltemq1m) ) + + IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN + write(0,*) 'STOP in nucond line 1192 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,f1,dqv,dqvr = ', dtemp,e1,f1,dqv,dqvr + write(0,*) ' d1,d1r,dtcon,ss1 = ',d1,d1r,dtcon,ss1 + write(0,*) ' dqc, dqr = ',dqc,dqr + write(0,*) ' qv,qc,qr = ',qx(mgs,lv)*1000.,qx(mgs,lc)*1000.,qx(mgs,lr)*1000. + write(0,*) ' i, j, k = ',igs(mgs),jy,kgs(mgs) + write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta + write(0,*) ' nc,dtp = ',nc,dtp + write(0,*) ' rwvent,xdia,crw,ccw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr),cx(mgs,lc) + write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr) + write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1 + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1m) + qv1m = qv1 + dqv + dqvr +! qv1mr = qv1r + dqvr + + qvs1m = qvs1 + dqvs + ss1m = qv1m/qvs1m + + ! check for undersaturation when no ice is present, if so, then reduce time step + IF ( ss1m .lt. 1. .and. (dqvii + dqvis) .eq. 0.0 ) THEN + dtcon = (0.5*dtcon) + IF ( dtcon .ge. dtcon1 ) THEN + GOTO 609 + ELSE + EXIT + ENDIF + ENDIF +! calculate full step: + dqv = -(ss1m - 1.)*d1*dtcon + dqvr = -(ss1m - 1.)*d1r*dtcon + + +! write(0,*) 'RK2a dqv1m = ',dqv + dtemp = -e1*f1*(dqv + dqvr) + + ! ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5) + + ! 7.6.2016: Test full calc of ltemq + ltemq1 = (temp1+dtemp-163.15)*fqsati+1.5 + ltemq1 = Min( nqsat, Max(1,ltemq1) ) + + IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN + write(0,*) 'STOP in nucond line 1230 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,dqv,dqvr = ', dtemp,e1,dqv,dqvr + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1) + + qv1 = qv1 + dqv + dqvr + + dqc = dqc - dqv + dqr = dqr - dqvr + + qvs1 = qvs1 + dqvs + ss1 = qv1/qvs1 + temp1 = temp1 + dtemp + IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or. & + & ss1 .eq. 1.00 .or. & + & ( n .gt. 10 .and. ss1 .lt. 1.0005 ) ) THEN +! write(0,*) 'RK2c break' + EXIT + ELSE + ss2 = ss1 + temp2 = temp1 + dt1 = dt1 + dtcon + n = n + 1 + ENDIF + ENDDO RK2c + + + dcloud = dqc ! qx(mgs,lv) - qv1 + thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr) + + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) + ENDIF + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp + ENDIF + qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + qx(mgs,lr) = qx(mgs,lr) + dqr +! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD + dqr)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & +!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*f1 + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) + +! + + ENDIF ! dcloud .gt. 0. + + + ELSE ! qc .le. qxmin(lc) + +! IF ( ssf(mgs) .gt. 0.0 .and. .not. flag_qndrop ) THEN ! flag_qndrop turns off primary nucleation when using wrf-chem with progn=1 + IF ( ssf(mgs) .gt. 0.0 ) THEN ! .and. ssmax(mgs) .lt. sscb ) THEN ! except that wrf-chem does not seem to initialize qc for activated aerosols, so keep this, after all + + IF ( iqcinit == 1 ) THEN + + qvs0 = 380.*exp(17.27*(temg(mgs)-273.)/(temg(mgs)- 36.))/pk(mgs) + + dcloud = Max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) ) + + ELSEIF ( iqcinit == 3 ) THEN + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & + & ((temg(mgs) - cbw)**2)) + DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + + ELSEIF ( iqcinit == 2 ) THEN +! R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ +! : (cp*(temg(mgs) - cbw)**2)) +! DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + ssmx = ssmxinit + +! IF ( ssf(mgs) > ssmx .and. ssmax(mgs) < 3.0 ) THEN +! IF ( ssf(mgs) > ssmx .and. ccnc(mgs) > 1.0 ) THEN +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK + IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test +! IF ( ssf(mgs) > ssmx ) THEN ! original condition + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + ELSE + dcloud = 0.0 + ENDIF + ENDIF + ELSE + dcloud = 0.0 + ENDIF + + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + ENDIF + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) + +!.... S. TWOMEY (1959) +! Note: get here if there is no previous cloud water and w > 0. + cn(mgs) = 0.0 + + IF ( ncdebug .ge. 1 ) THEN + write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs) + ENDIF + + IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem + + +! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN +! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & + & .and. ncdebug .ge. 1 ) THEN + write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & + & wvel(mgs), dcloud*1.e3 + IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ', & + & 1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3, & + & igs(mgs),kgs(mgs),temcg(mgs), & + & 1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc) + ENDIF + IF ( iccwflg .eq. 1 ) THEN + cn(mgs) = Min(cwccn*rho0(mgs)/rho00, Max(cn(mgs), & + & rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3))) + ENDIF + ELSE + cn(mgs) = 0.0 + dcloud = 0.0 +! cn(mgs) = Min(cwccn, & +! & rho0(mgs)*dcloud/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3) ) + ENDIF + + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) +! ccnc(mgs) = 0.0 + ENDIF +! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccna(mgs) = ccna(mgs) + cn(mgs) + ENDIF + +! write(91,*) 'nuc1: cn, ix, kz = ',cn(mgs),igs(mgs),kgs(mgs),wvel(mgs),cnexp,ccnc(mgs) + + IF( CN(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = CN(mgs) + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN + cx(mgs,lc) = 0. + ELSE + cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn) + ENDIF + + ENDIF ! }.not. flag_qndrop + + GOTO 613 + + END IF ! qc .gt. 0. + +! ES=EES(PIB(K)*PT) +! SQSAT=EPSI*ES/(PB(K)*1000.-ES) + +!.... CLOUD NUCLEATION +! T=PIB(K)*PT +! ES=1.E3*PB(K)*QV/EPSI + + IF ( wvel(mgs) .le. 0. ) GO TO 616 + IF ( cx(mgs,lc) .le. 0. ) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .GT. 1 .and. qx(mgs,lc) .le. qxmin(lc)) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .eq. 1 .and. wvel(mgs) .gt. 0. ) GO TO 613 !TWOMEY (1959) Nucleation +!.... ATTEMPT ZIEGLER CLOUD NUCLEATION IN CLOUD INTERIOR UNLESS... + 616 IF ( ssf(mgs) .LE. SUPCB .AND. wvel(mgs) .GT. 0. ) GO TO 631 !... weakly saturated updraft + IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND. & + & (ssfkp1(mgs) .GE. SUPMX .OR. & + & ssf(mgs) .GE. SUPMX .OR. & + & ssfkm1(mgs) .GE. SUPMX)) GO TO 631 !... too much vapour + IF (ssf(mgs) .LT. 1.E-10 .OR. ssf(mgs) .GE. SUPMX) GO TO 631 !... at the extremes for ss + +! +! get here if ( qc > 0 and ss > supcb) or (w < 0) +! + + if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" !mpidebug + + DSSDZ=0. + r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) + IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) + + IF ( irenuc < 2 ) THEN !{ + + IF ( kzend == nzend ) THEN + t0p3 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+3)) + t0p1 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+1)) + ELSE + t0p3 = t0(igs(mgs),jgs,kgs(mgs)+3) + t0p1 = t0(igs(mgs),jgs,kgs(mgs)+1) + ENDIF + + IF ( ( ssf(mgs) .gt. ssmax(mgs) .or. irenuc .eq. 1 ) & + & .and. ( ( lccn .lt. 1 .and. & + & cx(mgs,lc) .lt. cwccn*(Min(1.0,rho0(mgs)))) .or. & + & ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. ) ) & + & ) THEN + IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & + & .and. ssf(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .LT. SUPMX .and. ssfkp1(mgs) .ge. 0.0 & + & .AND. ssfkm1(mgs) .LT. SUPMX .AND. ssfkm1(mgs) .ge. 0.0 & + & .AND. ssfkp1(mgs) .gt. ssfkm1(mgs) & + & .and. t0p3 .gt. 233.2) THEN + DSSDZ = (ssfkp1(mgs) - ssfkm1(mgs))*R2DZM +! +! otherwise check for cloud base condition with updraft: +! + ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & +! IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 & !) + & .and. ssf(mgs) .gt. 0.0 .and. wvel(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .gt. 0.0 & + & .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 & + & .AND. ssf(mgs) .gt. ssfkm1(mgs) & + & .and. t0p1 .gt. 233.2) THEN + DSSDZ = 2.*(ssf(mgs) - ssfkm1(mgs))*R2DZM ! 1-sided difference + ENDIF + + ENDIF +! +!CLZ IF(wijk.LE.0.) CN=CCN*ssfilt(ix,jy,kz)**CCK +! note: CCN -> cwccn, DELT -> dtp + c1 = Max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ & + & (xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)) + IF ( lccn .lt. 1 ) THEN + CN(mgs) = cwccn*rho0(mgs)/rho00*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & (wvel(mgs)*DSSDZ) ) ! probably the vertical gradient dominates + ELSE + CN(mgs) = & + & Min(ccnc(mgs), cnuc(mgs)*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & ( wvel(mgs)*DSSDZ) ) ) +! IF ( cn(mgs) .gt. 0 ) ccnc(mgs) = ccnc(mgs) - cn(mgs) + ENDIF + + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( ccnc(mgs) .lt. 5.e7 .and. cn(mgs) .ge. 5.e7 ) THEN + cn(mgs) = 5.e7 + ccnc(mgs) = 0.0 + ELSEIF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) + ccnc(mgs) = 0.0 + ENDIF + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF + + ELSEIF ( irenuc == 2 ) THEN !} { + ! simple Twomey scheme +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( .false. .and. ny <= 2 ) THEN + write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn + write(0,*) 'wvel, cnuc, cn = ',wvel(mgs),cnuc(mgs),cn(mgs) + write(0,*) 'ccne0,cnexp,cck = ',ccne0,cnexp,cck + write(0,*) 'part1, part2 = ',CCNE0*cnuc(mgs)**(2./(2.+cck)), Max(0.0,wvel(mgs))**cnexp + write(0,*) 'ccnc, dqc, dqc/cwmasn = ',ccnc(mgs), dqc, 0.5*dqc/cwmasn + ENDIF + + IF ( icnuclimit > 0 ) THEN + tmp = ccnc(mgs) + cx(mgs,lc) + IF ( tmp < 330.34e6 ) THEN + ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 + ELSE + ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 + ENDIF + +! IF ( cn(mgs) > 0. ) THEN +! write(0,*) 'cn,tmp,ccwmax,cx,c-cx = ',cn(mgs),tmp,ccwmax,cx(mgs,lc),ccwmax - cx(mgs,lc) +! ENDIF + + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) + + ENDIF + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 5 ) THEN !} { + + ! modification of Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = Min( cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) + + + IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + + + CN(mgs) = Max( cn(mgs), cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ) ! this allows cn(mgs) > cnuc(mgs) + + ! cn(mgs) = Min( cn(mgs), cnuc(mgs) ) + +! IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + + ELSE + CN(mgs) = Min( cn(mgs), cnuc(mgs) - ccna(mgs) ) ! no more than remaining "base" CCN + ENDIF + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + dcrit = 2.0*2.0e-6 + dcloud = 1000.*dcrit**3*Pi/6. + ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass + ! check new droplet size: + ! tmp is number of droplets at diameter dcrit + tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) + cn(mgs) = Min(tmp, cn(mgs) ) + + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + dcrit = 2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ENDIF + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ELSEIF ( irenuc == 7 ) THEN !} { + + ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + cn(mgs) = 0.0 +! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation + IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 +! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN + ! prevent this branch from activating more than 70% of CCN + CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) ) +! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) + ! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) +!! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN +! IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN +! CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) '1: cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) +! ENDIF + + + ELSE ! }{ + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + +! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN + IF ( ssf(mgs) <= 1.0 ) THEN + CN(mgs) = cnuc(mgs)*Min(1.0, Max(0.0,ssf(mgs))**cck ) ! + ELSE + CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) ! +! write(0,*) 'iren7: ssf,ssmx = ',ssf(mgs),ssmax(mgs),cn(mgs),ccna(mgs),cnuc(mgs) +! write(0,*) 'c1,qv = ',c1,qx(mgs,lv),temp1,ltemq + ENDIF + + ! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) + ! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs) +! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN + IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN + CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) + ENDIF + + +! CN(mgs) = Min( Min(0.1,ssf(mgs)-1.)*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from +! CN(mgs) = Min( Min(0.5*cx(mgs,lc), Min(0.1,ssf(mgs)/100.)*cnuc(mgs)), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from + + CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from + + ENDIF ! } +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + + IF ( icnuclimit > 0 ) THEN +! max droplet conc. based on Chandrakar et al. (2016) and Konwar et al. (2012) + tmp = ccnc(mgs) - ccna(mgs) + cx(mgs,lc) + IF ( tmp < 330.34e6 ) THEN + ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 + ELSE + ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 + ENDIF + + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) + + ENDIF + + IF ( cn(mgs) + cnuf(mgs) > 0.0 ) THEN + + dcrit = 2.0*2.0e-6 + dcloud = 1000.*dcrit**3*Pi/6. + ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass + ! check new droplet size: + ! tmp is number of droplets at diameter dcrit + tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) + cn(mgs) = Min(tmp, cn(mgs) ) + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + cnuf(mgs) + + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + + dcrit = 2.0*2.5e-7 + dcloud = 1000.*dcrit**3*Pi/6.*(cn(mgs) + cnuf(mgs) ) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) + ENDIF + + ELSEIF ( irenuc == 8 ) THEN !} { + ! simple Twomey scheme +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + + cn(mgs) = 0.0 + + IF ( ccnc(mgs) > 0. ) THEN + CN(mgs) = CCNE0*ccnc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + + ELSEIF ( cx(mgs,lc) < 0.01e9 ) THEN + + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + +! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN + IF ( ssf(mgs) <= 1.0 ) THEN + CN(mgs) = 0.0 + ELSE +! CN(mgs) = 0.01e9*rho0(mgs)/rho00*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! + CN(mgs) = 0.01e9*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! + ENDIF + + ENDIF + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF + + + + ENDIF ! } + + ccna(mgs) = ccna(mgs) + cn(mgs) + + + + ENDIF ! irenuc >= 0 .and. .not. flag_qndrop + + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. + GO TO 631 +!.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT + + 613 CONTINUE + + 631 CONTINUE + +! +! Check for supersaturation greater than ssmx and adjust down +! + ssmx = maxsupersat + qv1 = qv0(mgs) + qwvp(mgs) + qvs1 = qvs(mgs) + +! IF ( flag_qndrop .and. do_satadj_for_wrfchem ) ssmx = 1.04 ! set lower threshold for progn=1 when using WRF-CHEM + + IF ( qv1 .gt. (ssmx*qvs1) ) THEN +! use line below to disable saturation adjustment when flag_qndrop is true +! IF ( qv1 .gt. (ssmx*qvs1) .and. .not. flag_qndrop ) THEN + + ss1 = qv1/qvs1 + + ssmx = 100.*(ssmx - 1.0) + + qvex = 0.0 + + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + + + + IF ( qvex .gt. 0.0 ) THEN + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp + ENDIF + qwvp(mgs) = qwvp(mgs) - qvex + qx(mgs,lc) = qx(mgs,lc) + qvex + IF ( .not. flag_qndrop) THEN + IF ( imaxsupopt == 1 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, xmas(mgs,lc) ) ) + ELSEIF ( imaxsupopt == 2 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas30,xmas(mgs,lc)) ) ) + ELSEIF ( imaxsupopt == 3 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmasx,xmas(mgs,lc)) ) ) +! cn(mgs) = 1.5*cxmin + ELSEIF ( imaxsupopt == 4 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) + ENDIF + ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ENDIF + +! write(iunit,*) 'theta = ',theta0(mgs) + thetap(mgs) + +! temg(mgs) = theta(mgs)*( pres(mgs) / poo ) ** cap + + ENDIF + + + ENDIF + +! +! Calculate droplet volume and check if it is within bounds. +! Adjust if necessary +! +! if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: check droplet volume" + + +! cx(mgs,lc) = Min( cwnccn(mgs), cx(mgs,lc) ) + IF( cx(mgs,lc) > cxmin .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN +! SVC(mgs) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)*xdn(mgs,lc)) + xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)) + + IF ( xmas(mgs,lc) < cwmasn .or. xmas(mgs,lc) > cwmasx ) THEN + tmp = cx(mgs,lc) + xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx ) + xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn ) + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + ENDIF + ENDIF + + +! IF( cx(mgs,lc) .GT. 10.e6 .AND. qx(mgs,lc) .GT. qxmin(lc) ) GO TO 681 +! ccwtmp = cx(mgs,lc) +! cwmastmp = xmas(mgs,lc) +! xmas(mgs,lc) = Max(xmas(mgs,lc), cwmasn) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. cx(mgs,lc) .le. 0.) THEN +! cx(mgs,lc) = Min(0.5*cwccn,rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)) +! xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! ENDIF +! IF (cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .GT. qxmin(lc)) & +! & xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .LT. cwmasn) & +! & xmas(mgs,lc) = cwmasn +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .GT. cwmasx) & +! & xmas(mgs,lc) = cwmasx +! IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN +! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc)) +! ENDIF +! +! +! 681 CONTINUE + + + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + + + IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr)) & + & xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr) + IF (xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr) + + ENDIF + + + + ENDDO ! mgs + + +! ################################################################ + DO mgs=1,ngscnt + IF ( lss > 1 .and. ssf(mgs) .gt. ssmax(mgs) & + & .and. ( idecss .eq. 0 .or. qx(mgs,lc) .gt. qxmin(lc)) ) THEN + ssmax(mgs) = ssf(mgs) + ENDIF + ENDDO +! + + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qv0(mgs) + qwvp(mgs) +! tmp3d(igs(mgs),jy,kgs(mgs)) = tmp3d(igs(mgs),jy,kgs(mgs)) + t9(igs(mgs),jy,kgs(mgs)) ! pi0(mgs) ! wvdf(mgs) ! ssf(mgs) ! cn(mgs) +! + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF + + if ( ido(lc) .eq. 1 ) then + an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) + & + & min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 ) +! qx(mgs,lc) = an(igs(mgs),jy,kgs(mgs),lc) + end if +! + + if ( ido(lr) .eq. 1 .and. rcond == 2 ) then + an(igs(mgs),jy,kgs(mgs),lr) = qx(mgs,lr) + & + & min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 ) +! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) + end if + + + + IF ( ipconc .ge. 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) + IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) ) + IF ( lccn .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + IF ( lccnuf .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) ) + ENDIF + IF ( lccna .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccna) = Max(0.0, ccna(mgs) ) + ENDIF + ENDIF + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0) + ENDIF + end do + + +29998 continue + + + if ( kz .gt. nz-1 .and. ix .ge. nxi) then + if ( ix .ge. nxi ) then + go to 2200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if + + if ( ix .ge. nxi ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if + + 2000 continue ! inumgs + 2200 continue +! +! end of gather scatter (for this jy slice) + + +!#ifdef COMMAS +! GOTO 9999 +!#endif + +! Redistribute inappreciable cloud particles and charge +! +! Redistribution everywhere in the domain... +! + frac = 1.0 ! 0.25 ! 1.0 ! 0.2 +! +! alternate test version for ipconc .ge. 3 +! just vaporize stuff to prevent noise in the number concentrations + + + do kz = 1,nz +! do jy = 1,1 + do ix = 1,nxi + + t0(ix,jy,kz) = an(ix,jy,kz,lt)*t77(ix,jy,kz) + + zerocx(:) = .false. + DO il = lc,lhab + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) + IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. an(ix,jy,kz,lz(il)) < zxmin ) + ELSE + IF ( il == lc ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM) + ELSE + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) + ENDIF + ENDIF + ENDDO + + IF ( lhl .gt. 1 ) THEN + + + if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then + +! IF ( an(ix,jy,kz,lhl) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) + an(ix,jy,kz,lhl) = 0.0 +! ENDIF + + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnhl) = 0.0 + ENDIF + + IF ( lvhl .gt. 1 ) THEN + an(ix,jy,kz,lvhl) = 0.0 + ENDIF + + IF ( lhlw .gt. 1 ) THEN + an(ix,jy,kz,lhlw) = 0.0 + ENDIF + + IF ( lzhl .gt. 1 ) THEN + an(ix,jy,kz,lzhl) = 0.0 + ENDIF + + ELSE + IF ( lvol(lhl) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE ! in case volume is zero but mass is above threshold (should not happen, of course) + tmp = rho_qhl + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + + IF ( tmp .lt. xdnmn(lhl) ) THEN + tmp = Max( xdnmn(lhl), tmp ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + + IF ( tmp .gt. xdnmx(lhl) .and. lhlw .le. 0 ) THEN ! no liquid allowed on hail + tmp = Min( xdnmx(lhl), tmp ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ELSEIF ( tmp .gt. xdnmx(lhl) .and. lhlw .gt. 1 ) THEN ! allow for liquid on hail + fw = an(ix,jy,kz,lhlw)/an(ix,jy,kz,lhl) +! tmpmx = xdnmx(lhl) + fw*(xdnmx(lr) - xdnmx(lhl)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + + tmpmx = xdnmx(lhl)/( 1. - fw*(1. - xdnmx(lhl)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmpmx + ENDIF + +! IF ( tmp .gt. xdnmx(lhl) .and. an(ix,jy,kz,lhlw) .lt. qxmin(lhl) ) THEN +! tmp = Min( xdnmx(lhl), tmp ) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ENDIF + ENDIF + + IF ( lhlw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhlw) .gt. 0.98*an(ix,jy,kz,lhl) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + ENDIF + + ENDIF + + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN + + IF ( lvhl .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl)) + tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohlmn ) THEN + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.) + an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) + ENDIF + + ENDIF +! ELSE ! check mean size here? + + end if + + + + ENDIF !lhl + + + if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then + +! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) + an(ix,jy,kz,lh) = 0.0 +! ENDIF + + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnh) = 0.0 + ENDIF + + IF ( lvh .gt. 1 ) THEN + an(ix,jy,kz,lvh) = 0.0 + ENDIF + + IF ( lhw .gt. 1 ) THEN + an(ix,jy,kz,lhw) = 0.0 + ENDIF + + IF ( lzh .gt. 1 ) THEN + an(ix,jy,kz,lzh) = 0.0 + ENDIF + + ELSE + IF ( lvol(lh) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + tmp = rho_qh + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + + IF ( tmp .lt. xdnmn(lh) ) THEN + tmp = Max( xdnmn(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + + IF ( tmp .gt. xdnmx(lh) .and. lhw .le. 0 ) THEN ! no liquid allowed on graupel + tmp = Min( xdnmx(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ELSEIF ( tmp .gt. xdnmx(lh) .and. lhw .gt. 1 ) THEN ! allow for liquid on graupel + fw = an(ix,jy,kz,lhw)/an(ix,jy,kz,lh) +! tmpmx = xdnmx(lh) + fw*(xdnmx(lr) - xdnmx(lh)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + tmpmx = xdnmx(lh)/( 1. - fw*(1. - xdnmx(lh)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmpmx + ENDIF + +! IF ( tmp .gt. xdnmx(lh) .and. an(ix,jy,kz,lhw) .lt. qxmin(lh) ) THEN +! tmp = Min( xdnmx(lh), tmp ) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ENDIF + + ENDIF + + IF ( lhw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhw) .gt. 0.98*an(ix,jy,kz,lh) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + ENDIF + + ENDIF + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = xdn0(lh) + ENDIF + hwdn = Max( xdnmn(lh), hwdn ) + ELSE + hwdn = xdn0(lh) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh)) + tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohmn ) THEN +! tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) +! tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.) + ENDIF + + ENDIF + + end if + + + if ( an(ix,jy,kz,ls) .lt. frac*qxmin(ls) .or. zerocx(ls) & ! .or. an(ix,jy,kz,lns) .lt. 0.1 ! .and. + & ) then + IF ( t0(ix,jy,kz) .lt. 273.15 ) THEN +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF + + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF + + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF + + ELSE +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF + + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF + + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF + + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lnr) = an(ix,jy,kz,lnr) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + ENDIF + + + ELSEIF ( lvol(ls) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + IF ( tmp .gt. xdnmx(ls) .or. tmp .lt. xdnmn(ls) ) THEN + tmp = Min( xdnmx(ls), Max( xdnmn(ls), tmp ) ) + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF + ELSE + tmp = rho_qs + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF + + + end if + + + if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & + & ) then + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) + an(ix,jy,kz,lr) = 0.0 + IF ( ipconc .ge. 3 ) THEN +! an(ix,jy,kz,lnc) = an(ix,jy,kz,lnc) + an(ix,jy,kz,lnr) + an(ix,jy,kz,lnr) = 0.0 + ENDIF + + end if + +! +! for qci +! + IF ( an(ix,jy,kz,li) .le. frac*qxmin(li) .or. zerocx(li) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) + an(ix,jy,kz,li)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lni) = 0.0 + ENDIF + ENDIF + +! +! for qis +! + IF ( lis > 1 ) THEN ! { + IF ( an(ix,jy,kz,lis) .le. frac*qxmin(lis) .or. zerocx(lis) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN ! { { + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis) + an(ix,jy,kz,lis)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lnis) = 0.0 + ENDIF + + ELSEIF ( icespheres >= 2 ) THEN ! } { + km1 = Max(1, kz-1) + IF ( 0.5*( w(ix,jy,kz) + w(ix,jy,kz+1)) < -1.0 .or. & + & (icespheres == 3 .and. ( t0(ix,jy,kz) < 232.15 .or. an(ix,jy,kz,lc) < qxmin(lc) ) ) .or. & + & (icespheres == 5 .and. ( t0(ix,jy,kz) < 232.15 .or. & + & ( an(ix,jy,kz,lc) < qxmin(lc) .and. an(ix,jy,km1,lc) < qxmin(lc) )) ) .or. & + & (icespheres == 4 .and. ( t0(ix,jy,kz) < 235.15 )) ) THEN ! transfer to regular ice crystals in downdraft or at low temp + an(ix,jy,kz,li) = an(ix,jy,kz,li) + an(ix,jy,kz,lis) + an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lnis) + an(ix,jy,kz,lis)= 0.0 + an(ix,jy,kz,lnis)= 0.0 + + ENDIF + + ENDIF ! } } + ENDIF ! } + +! +! for qcw +! + + IF ( an(ix,jy,kz,lc) .le. frac*qxmin(lc) .or. zerocx(lc) & + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) + an(ix,jy,kz,lc)= 0.0 + IF ( ipconc .ge. 2 ) THEN + IF ( lccn .gt. 1 ) THEN + an(ix,jy,kz,lccn) = & + & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ENDIF + an(ix,jy,kz,lnc) = 0.0 + + IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) + + IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) + + ELSEIF ( lccn > 1 .and. restoreccn ) THEN + ! in this case, we are treating the ccn field as ccna + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) +! IF ( ny == 2 .and. ix == nx/2 ) THEN +! write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst) +! write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) +! ENDIF + IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) ) THEN + ! an(ix,jy,kz,lccn) = & + ! an(ix,jy,kz,lccn) + Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst)) + ! Equivalent form after expanding last term: + an(ix,jy,kz,lccn) = & + dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) + ENDIF + + ENDIF + + ENDIF + + ENDIF + + end do +! end do + end do + + + IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' +! +! + + + 9999 RETURN + + END SUBROUTINE NUCOND + + +! ##################################################################### +! ##################################################################### + + + + +!c-------------------------------------------------------------------------- +! +! +!-------------------------------------------------------------------------- +! + + subroutine nssl_2mom_gs & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,dtp,gz & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn,p2 & + & ,pn,w,iunit & + & ,t00,t77, & + & ventr,ventc,c1sw,jgs,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & + & cdx, & + & xdn0,tmp3d,tkediss & + & ,timevtcalc,axtra,io_flag & + & ,rainprod2d, evapprod2d & + & ,elec,its,ids,ide,jds,jde & + & ) + + +! +!-------------------------------------------------------------------------- +! +! Ziegler 1985 parameterized microphysics (also Zrnic et al. 1993) +! 1) cloud water +! 2) rain +! 3) column ice +! 6) snow +! 11) graupel/hail +! +!-------------------------------------------------------------------------- +! +! Notes: +! +! 4/27/2009: allows for liquid water to be advected on snow and graupel particles using flag "mixedphase" +! +! 3/14/2007: (APS) added qproc temp to make microphysic process timeseries +! +! 10/17/2006: added flag (iehw) to select how to calculate ehw +! +! 10/5/2006: switched chacr to integrated version rather than assuming that average rain +! drop mass does not change. This acts to reduce rain size somewhat via graupel +! collection. +! Use Mason data for ehw, with scaling toward ehw=1 as air density decreases. +! +! 10/3/2006: Turned off Meyers nucleation for T > -5 (can turn on with imeyers5 flag) +! Turned off contact nucleation in updrafts +! +! 7/24/2006: Turned on Meyers nucleation for -5 < T < 0 +! +! 5/12/2006: Converted qsacw/csacw and qsaci/csaci to Z93 +! +! 5/12/2006: Put a threshold on Bigg rain freezing. If the frozen drops +! have an average volume less than xvhmn, then the drops are put +! into snow instead of graupel/hail. +! +! Fixed bug when vapor deposition was limited. +! +! 5/13/2006: Note that qhacr has a large effect, but Z85 did not include it. +! Turned off qsacr (set to zero). +! +! 9/14/2007: erm: recalculate vx(lh) after setting xdn(lh) in case xdn was out of allowed range. +! added parameter rimc3 for minimum rime density. Default value set at 170. kg/m**3 +! instead of previous use of 100. (Farley, 1987) +! +!-------------------------------------------------------------------------- +! +! general declarations +! +!-------------------------------------------------------------------------- +! +! +! + + + implicit none +! +! integer icond +! parameter ( icond = 2 ) + + integer, parameter :: ng1 = 1 + + integer nx,ny,nz,na,nba,nv + integer nor,norz,istag,jstag,kstag ! ,nht,ngt,igsr + integer iwrite + real dtp,dx,dy,dz + + logical, intent(in) :: io_flag + + integer itile,jtile,ktile + integer ixbeg,jybeg + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + integer :: my_rank = 0 + integer, parameter :: myprock = 1, nprock = 1 + real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + + real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + + real :: galpharaut + real :: xvbarmax + + integer jyslab,its,ids,ide,jds,jde ! domain boundaries + integer, intent(in) :: iunit !,iunit0 + real qvex + integer iraincv, icgxconv + parameter ( iraincv = 1, icgxconv = 1) + real ffrz + + real qcitmp,cirdiatmp ! ,qiptmp,qirtmp + real ccwtmp,ccitmp ! ,ciptmp,cirtmp + real cpqc,cpci ! ,cpip,cpir + real cpqc0,cpci0 ! ,cpip0,cpir0 + real scfac ! ,cpip1 + + double precision dp1 + + double precision frac, frach, xvfrz + + double precision :: timevtcalc + double precision :: dpt1,dpt2 + + logical, parameter :: gammacheck = .false. + integer :: luindex + double precision :: tmpgam + logical, parameter :: usegamxinfcnu = .false. + logical, parameter :: usegamxinf = .false. + logical, parameter :: usegamxinf2 = .false. + logical, parameter :: usegamxinf3 = .false. +! real rar ! rime accretion rate as calculated from qxacw + + +! a few vars for time-split fallout + real vtmax + integer n,ndfall + + double precision chgneg,chgpos,sctot + + real temgtmp + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + + real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! dz + + real qimax,xni0,roqi0 + + + real dv + + real dtptmp + integer itest,nidx,id1,jd1,kd1 + parameter (itest=1) + parameter (nidx=10) + parameter (id1=1,jd1=1,kd1=1) + integer ierr + integer iend + + integer ix,kz, il, ic, ir, icp1, irp1, ip1,jp1,kp1 + integer :: jy + integer i,j,k,i1 + integer kzb,kze + real slope1, slope2 + real x1, x2, x3 + real eps,eps2 + parameter (eps=1.e-20,eps2=1.e-5) +! +! Other elec. vars +! + real temele + real trev + + logical ldovol, ishail, ltest, wtest + logical , parameter :: alp0flag = .false. +! +! +! wind indicies +! + integer mu,mv,mw + parameter (mu=1,mv=2,mw=3) +! +! conversion parameters +! + integer mqcw,mqxw,mtem,mrho,mtim + parameter (mqcw=21,mqxw=21,mtem=21,mrho=5,mtim=6) + + real xftim,xftimi,yftim, xftem,yftem, xfqcw,yfqcw, xfqxw,yfqxw + parameter (xftim=0.05,xftimi = 1./xftim,yftim=1.) + parameter (xftem=0.5,yftem=1.) + parameter (xfqcw=2000.,yfqcw=1.) + parameter (xfqxw=2000.,yfqxw=1.) + real dtfac + parameter ( dtfac = 1.0 ) + integer ido(lc:lqmx) + +! integer iexy(lc:lqmx,lc:lqmx) +! integer ieswi, ieswir, ieswip, ieswc, ieswr +! integer ieglsw, iegli, ieglir, ieglip, ieglc, ieglr +! integer iegmsw, iegmi, iegmir, iegmip, iegmc, iegmr +! integer ieghsw, ieghi, ieghir, ieghip, ieghc, ieghr +! integer iefwsw, iefwi, iefwir, iefwip, iefwc, iefwr +! integer iehwsw, iehwi, iehwir, iehwip, iehwc, iehwr +! integer iehlsw, iehli, iehlir, iehlip, iehlc, iehlr +! real delqnsa, delqxsa, delqnsb, delqxsb, delqnia, delqxia +! real delqnra, delqxra + + real delqnxa(lc:lqmx) + real delqxxa(lc:lqmx) +! +! external temporary arrays +! + real t00(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t77(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t1(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t3(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t4(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t5(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t6(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + + real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + +! +! declarations microphyscs and for gather/scatter +! + integer nxmpb,nzmpb,nxz + integer jgs,mgs,ngs,numgs + parameter (ngs=500) !500) + integer, parameter :: ngsz = 500 + integer ntt + parameter (ntt=300) + + real dvmgs(ngs) + + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs),kgsm2(ngs) + integer ncuse + parameter (ncuse=0) + integer il0(ngs),il5(ngs),il2(ngs),il3(ngs) +! integer il1m(ngs),il2m(ngs),il3m(ngs),il4m(ngs),il5m(ngs) +! + real tdtol,temsav,tfrcbw,tfrcbi + real, parameter :: thnuc = 235.15 +! +! Ice Multiplication Arrays. +! + real fimt1(ngs),fimta(ngs),fimt2(ngs) !,qmul1(ngs),qmul2(ngs) + real xcwmas +! +! +! Variables for Ziegler warm rain microphysics +! + + + real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs) + real cwnccn(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor, tmpdiam + real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter (same as area-weighted diameter), 4 for mass-weighted diameter + real ssmax(ngs) ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real bfnu, bfnu0, bfnu1 + parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0) ) + real ventr, ventc + real volb, aa1, aa2 + double precision t2s, xdp + double precision xl2p(ngs),rb(ngs) + parameter ( aa1 = 9.44e15, aa2 = 5.78e3 ) ! a1 in Ziegler +! snow parameters: + real cexs, cecs + parameter ( cexs = 0.1, cecs = 0.5 ) + real rvt ! ratio of collection kernels (Zrnic et al, 1993) + parameter ( rvt = 0.104 ) + real kfrag ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) + parameter ( kfrag = 1.0e-6 ) + real mfrag ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) + parameter ( mfrag = 1.0e-10) + double precision cautn(ngs), rh(ngs), nh(ngs) + real ex1, ft, rhoinv(ngs) + double precision ec0(ngs) + + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super + real dw,dwr + double precision :: tmpz, tmpzmlt + real ratio, delx, dely + real dbigg,volt + real chgtmp,fac,mixedphasefac + real x,y,y2,del,r,rtmp,alpr + double precision :: vent1,vent2 + double precision :: g1palp,g4palp + double precision :: g1palpinf,g4palpinf + real fqt !charge separation as fn of temperature from Dong and Hallett 1992 + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + real c1sw ! integration factor for snow melting with snu = -0.8 + real, parameter :: vr1mm = 5.23599e-10 ! volume of 1mm diameter sphere (m**3) + real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3 ! volume of a 3 mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 ! volume of 4.5mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real vmlt,vshd, vshdgs(ngs,lh:lhab), maxmassfac(lc:lhab) + real rhosm + parameter ( rhosm = 500. ) + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real cn(ngs) + double precision xvc, xvr + real mwfac +! real es(ngs) ! ss(ngs), +! real eis(ngs) + + real rwmasn,rwmasx + + real vgra,vfrz + parameter ( vgra = 0.523599*(1.0e-3)**3 ) + +! real, parameter :: epsi = 0.622 +! real, parameter :: d = 0.266 + real :: d, dold, denom,denominv,vth + double precision :: h1, h2, h3, h4,denomdp, denominvdp + real r1,qevap ! ,slv + + real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia,rmas + real :: snowmeltmass = 0 + + real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain + real, parameter :: rimedens = 500. ! default rime density + +! real svc(ngs) ! droplet volume +! +! contact freezing nucleation +! + real raero,kaero !assumd aerosol radius, thermal conductivity + parameter ( raero = 3.e-7, kaero = 5.39e-3 ) + real kb ! Boltzman constant J K-1 + parameter (kb = 1.3807e-23) + + real knud(ngs),knuda(ngs) !knudsen number and correction factor + real gtp(ngs) !G(T,p) = 1/(a' + b') Cotton 72b + real dfar(ngs) !aerosol diffusivity + real fn1(ngs),fn2(ngs),fnft(ngs) + + real ccia(ngs) + real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs) +! +! misc +! + real ni,nis,nr,d0 + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs),dqcitmp(ngs),dqwvtmp(ngs) + real tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) + real temgkm1(ngs), temgkm2(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real elv(ngs),elf(ngs),els(ngs) + real tsqr(ngs),ssi(ngs),ssw(ngs) + real qcwtmp(ngs),qtmp,qtot(ngs) + real qcond(ngs) + real ctmp, sctmp + real cimasn,cimasx,ccimx + real pid4 + real cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1 + real gcnup1,gcnup2 + real gf73rds, gf83rds + real gamice73fac, gamsnow73fac + real gf43rds, gf53rds + real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn + parameter ( rwradmn = 50.e-6 ) + real dh0 + real dg0(ngs) + + real clionpmx,clionnmx + parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 +! +! other arrays + + real fwet1(ngs),fwet2(ngs) + real fmlt1(ngs),fmlt2(ngs) + real fvds(ngs),fvce(ngs),fiinit(ngs) + real fvent(ngs),fraci(ngs),fracl(ngs) +! + real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs) + real felv(ngs),fels(ngs),felf(ngs) + real felvcp(ngs),felscp(ngs),felfcp(ngs) + real felvpi(ngs),felspi(ngs),felfpi(ngs) + real felvs(ngs),felss(ngs) ! ,felfs(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) ! heat capacities of ice and liquid + real fschm(ngs),fpndl(ngs) + real fgamw(ngs),fgams(ngs) + real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) + + real cvm,cpm,rmm + + real, parameter :: rovcp = rd/cp + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure +! + real fcci(ngs), fcip(ngs) +! + real :: sfm1(ngs),sfm2(ngs) + real :: gfm1(ngs),gfm2(ngs) + real :: hfm1(ngs),hfm2(ngs) + + logical :: wetsfc(ngs),wetsfchl(ngs) + logical :: wetgrowth(ngs), wetgrowthhl(ngs) + + real qitmp(ngs),qistmp(ngs) + + real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs) + real rzxs(ngs) + real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs),cdh(ngs),cdhl(ngs) + real vt2ave(ngs) + + real :: qcwresv(ngs), ccwresv(ngs) ! "reserved" droplet mass and number that are too small for accretion + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: qxwlg(ngs,lh:lhab) + real :: cx(ngs,lc:lhab) + real :: cxmxd(ngs,lc:lhab) + real :: qxmxd(ngs,lv:lhab) + real :: scx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: cdxgs(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vtwtdia(ngs,lr:lhab) ! sweep-out volume weighted diameter + real :: rarx(ngs,ls:lhab) + real :: vx(ngs,li:lhab) + real :: rimdn(ngs,li:lhab) + real :: raindn(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: dab0lh(ngs,lc:lhab,lr:lhab) + real :: dab1lh(ngs,lc:lhab,lr:lhab) + + real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis + real :: qsimxsub(ngs) ! max depositionof qi+qs+qis + logical,parameter :: DoSublimationFix = .true. + real :: qrtmp(ngs),qvtmp(ngs),qctmp(ngs) + real :: felvcptmp,felscptmp,qsstmp + real :: thetatmp, thetaptmp, temcgtmp,qvaptmp + real :: qvstmp, qisstmp, qvptmp, qitmp1, qctmp1 + + real :: galphrout + + real ventrx(ngs) + real ventrxn(ngs) + real g1shr, alphashr + real g1mlr, alphamlr + real massfacshr, massfacmlr + + real :: qhgt8mm ! ice mass greater than 8mm + real :: qhwgt8mm ! ice + max water mass greater than 8mm + real :: qhgt10mm ! mass greater than 10mm + real :: qhgt20mm ! mass greater than 20mm + real :: fwmhtmp + real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles + real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) ! d1t is the diameter of the ice sphere with the mass (0.268e-3 kg) of an 8mm spherical drop + real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield +! + real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) + integer, parameter :: ndiam = 10 + integer :: numdiam + real hwvent0(ndiam+4),hlvent0 ! 0 to d1 + real hwvent1,hlvent1 ! d1 to infinity + real hwvent2,hlvent2 ! d2 to infinity + real gama0,gamb0 + real gama1,gamb1 + real gama2,gamb2 +! real, parameter :: mltdiam1 = 9.0e-3, mltdiam1p5 = 16.0e-3, mltdiam2 = 19.0e-3, mltdiam3 = 200.0e-3, mltdiam05 = 4.5e-3 + real :: mltdiam(ndiam+4) + real mltmass0inv,mltmass1inv,mltmass2inv, mltmass1cgs, mltmass2cgs,mltmass3inv, mltmass3cgs + real qhmlr0, qhmlr05, qhmlr1, qhmlr2,qhmlr3, qhmlr12, qhmlr23 + real qhlmlr0, qhlmlr05, qhlmlr1, qhlmlr2,qhlmlr3, qhlmlr12, qhlmlr23 + real qxd1, cxd1, zxd1 ! mass and number up to mltdiam1 + real qxd05, cxd05 ! mass and number up to mltdiam1/2 + + real :: qxd(ndiam+4), cxd(ndiam+4), qhml(ndiam+4), qhml0(ndiam+4) + real :: dqxd(ndiam+4), dcxd(ndiam+4), dqhml(ndiam+4) + + + real civent(ngs) + real isvent(ngs) +! + real xmascw(ngs) + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real dnmx + real :: xdiamxmas(ngs,lc:lhab) +! + real cilen(ngs) ! ,ciplen(ngs) +! +! + real rwcap(ngs),swcap(ngs) + real hwcap(ngs) + real hlcap(ngs) + real cicap(ngs) + real iscap(ngs) + + real qvimxd(ngs) + real qimxd(ngs),qismxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) + real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs) + real cionpmxd(ngs),cionnmxd(ngs) + real clionpmxd(ngs),clionnmxd(ngs) + + + real elec(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! Ez (elecsave) + +! +! + ! Hallett-Mossop arrays + real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs) + real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs) + + ! splinters from drop freezing + real csplinter(ngs),qsplinter(ngs) + real csplinter2(ngs),qsplinter2(ngs) +! +! +! concentration arrays... +! + real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs) + real :: chlcnhhl(ngs) ! number of new hail particles (may be different from number of lost graupel) + real cracif(ngs), ciacrf(ngs) + real cracr(ngs) + +! + real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs) + real cicint(ngs) + real cipint(ngs) + real ciacw(ngs), cwacii(ngs) + real ciacr(ngs), craci(ngs) + real csacw(ngs) + real csacr(ngs) + real csaci(ngs), csacs(ngs) + real cracw(ngs) + real chacw(ngs), chacr(ngs) + real :: chlacw(ngs) ! = 0.0 + real chaci(ngs), chacs(ngs) +! + real :: chlacr(ngs) + real :: chlaci(ngs), chlacs(ngs) + real crcnw(ngs) + real cidpv(ngs),cisbv(ngs) + real cisdpv(ngs),cissbv(ngs) + real cimlr(ngs),cismlr(ngs) + + real chlsbv(ngs), chldpv(ngs) + real chlmlr(ngs), chlmlrr(ngs) +! real chlmlrsave(ngs),chlsave(ngs),qhlsave(ngs) + real chlshr(ngs), chlshrr(ngs) + + + real chdpv(ngs),chsbv(ngs) + real chmlr(ngs),chcev(ngs) + real chmlrr(ngs) + real chshr(ngs), chshrr(ngs) + + real csdpv(ngs),cssbv(ngs) + real csmlr(ngs),csmlrr(ngs),cscev(ngs) + real csshr(ngs), csshrr(ngs) + + real crcev(ngs) + real crshr(ngs) +! +! +! arrays for w-ac-x ; x-ac-w +! +! +! + real qrcnw(ngs), qwcnr(ngs) + real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) + + + real qracw(ngs) ! qwacr(ngs), + real qiacw(ngs) !, qwaci(ngs) + + real qsacw(ngs) ! ,qwacs(ngs), + real qhacw(ngs) ! qwach(ngs), + real :: qhlacw(ngs) ! = 0.0 + real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + +! + real qsacws(ngs) + +! +! arrays for x-ac-r and r-ac-x; +! + real qsacr(ngs),qracs(ngs) + real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs) + real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) + real qiacr(ngs),qraci(ngs) + + real ziacr(ngs) + + real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) + + real :: qhlacr(ngs),qhlacrmlr(ngs) ! = 0.0 + real qsacrs(ngs) !,qracss(ngs) +! +! ice - ice interactions +! + real qsaci(ngs) + real qsacis(ngs) + real qhaci(ngs) + real qhacs(ngs) + + real :: qhacis(ngs) = 0.0 + real :: chacis(ngs) = 0.0 + real :: chacis0(ngs) = 0.0 + + real :: csaci0(ngs) ! collision rate only + real :: chaci0(ngs) ! collision rate only + real :: chacs0(ngs) ! collision rate only + real :: chlaci0(ngs) ! = 0.0 + real :: chlacis(ngs) = 0.0 + real :: chlacis0(ngs) = 0.0 + real :: chlacs0(ngs) ! = 0.0 + + real :: qsaci0(ngs) ! collision rate only + real :: qsacis0(ngs) ! collision rate only + real :: qhaci0(ngs) ! collision rate only + real :: qhacis0(ngs) ! collision rate only + real :: qhacs0(ngs) ! collision rate only + real :: qhlaci0(ngs) ! = 0.0 + real :: qhlacis0(ngs) ! = 0.0 + real :: qhlacs0(ngs) ! = 0.0 + + real :: qhlaci(ngs) ! = 0.0 + real :: qhlacis(ngs) ! = 0.0 + real :: qhlacs(ngs) ! = 0.0 +! +! conversions +! + real qrfrz(ngs) ! , qirirhr(ngs) + real zrfrz(ngs), zrfrzf(ngs), zrfrzs(ngs) + real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) + real zhacw(ngs), zhacs(ngs), zhaci(ngs) + real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs) + real zhmlrtmp,zhmlr0inf,zhlmlr0inf + real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs) + real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) + real zhcns(ngs), zhcni(ngs) + real zhwdn(ngs) ! change in Z due to density changes + real zhldn(ngs) ! change in Z due to density changes + + real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs) + real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs) + + + real vrfrzf(ngs), viacrf(ngs) + real qrfrzs(ngs), qrfrzf(ngs) + real qwfrz(ngs), qwctfz(ngs) + real cwfrz(ngs), cwctfz(ngs) + real qwfrzis(ngs), qwctfzis(ngs) ! droplet freezing to ice spheres + real cwfrzis(ngs), cwctfzis(ngs) + real qwfrzc(ngs), qwctfzc(ngs) ! droplet freezing to columns + real cwfrzc(ngs), cwctfzc(ngs) + real qwfrzp(ngs), qwctfzp(ngs) ! droplet freezing to plates + real cwfrzp(ngs), cwctfzp(ngs) + real xcolmn(ngs), xplate(ngs) + real ciihr(ngs), qiihr(ngs) + real cicichr(ngs), qicichr(ngs) + real cipiphr(ngs), qipiphr(ngs) + real qscni(ngs), cscni(ngs), cscnis(ngs) + real qscnvi(ngs), cscnvi(ngs), cscnvis(ngs) + real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs) + real qscnh(ngs), cscnh(ngs), vscnh(ngs) + real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs) + real qiint(ngs),qipipnt(ngs),qicicnt(ngs) + real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs) + real tke(ngs) + real uvel(ngs),vvel(ngs) +! + real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs), + real qimlr(ngs),qidsv(ngs),qisdsv(ngs),qidsvp(ngs) ! ,qicev(ngs) + real qismlr(ngs) + +! + real qfdpv(ngs),qfsbv(ngs) ! qfcnv(ngs),qfevv(ngs), + real qfmlr(ngs),qfdsv(ngs) ! ,qfcev(ngs) + real qfwet(ngs),qfdry(ngs),qfshr(ngs) + real qfshrp(ngs) +! + real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), + real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) + real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) +! + real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs) +! + real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs), + real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) + real qhlcev(ngs), chlcev(ngs) + real qhwet(ngs),qhdry(ngs),qhshr(ngs) + real qhshrp(ngs) + real qhshh(ngs) !accreted water that remains on graupel + real qhmlh(ngs) !melt water that remains on graupel + real qhfzh(ngs) !water that freezes on mixed-phase graupel + real qhlfzhl(ngs) !water that freezes on mixed-phase hail + + real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters + real qhfzhlg(ngs) !water that freezes on mixed-phase graupel (large sizes) + real qhlfzhllg(ngs) !water that freezes on mixed-phase hail (large sizes) + real qhlcevlg(ngs), chlcevlg(ngs) + real qhcevlg(ngs), chcevlg(ngs) + + real vhfzh(ngs) ! change in volume from water that freezes on mixed-phase graupel + real vhlfzhl(ngs) ! change in volume from water that freezes on mixed-phase hail + + real vhshdr(ngs) !accreted water that leaves on graupel (mixedphase) + real vhlshdr(ngs) !accreted water that leaves on hail (mixedphase) + real vhmlr(ngs) !melt water that leaves graupel (single phase) + real vhlmlr(ngs) !melt water that leaves hail (single phase) + real vhsoak(ngs) ! aquired water that seeps into graupel. + real vhlsoak(ngs) ! aquired water that seeps into hail. +! + real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs), + real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs) + real qswet(ngs),qsdry(ngs),qsshr(ngs) + real qsshrp(ngs) + real qsfzs(ngs) +! +! + real qipdpv(ngs),qipsbv(ngs) + real qipmlr(ngs),qipdsv(ngs) +! + real qirdpv(ngs),qirsbv(ngs) + real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs) +! + real qgldpv(ngs),qglsbv(ngs) + real qglmlr(ngs),qgldsv(ngs) + real qglwet(ngs),qgldry(ngs),qglshr(ngs) + real qglshrp(ngs) +! + real qgmdpv(ngs),qgmsbv(ngs) + real qgmmlr(ngs),qgmdsv(ngs) + real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs) + real qgmshrp(ngs) + real qghdpv(ngs),qghsbv(ngs) + real qghmlr(ngs),qghdsv(ngs) + real qghwet(ngs),qghdry(ngs),qghshr(ngs) + real qghshrp(ngs) +! + real qrztot(ngs),qrzmax(ngs),qrzfac(ngs) + real qrcev(ngs) + real qrshr(ngs) + real fsw(ngs),fhw(ngs),fhlw(ngs) !liquid water fractions + real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions + real qhcnf(ngs) + real :: qhlcnh(ngs) ! = 0.0 + real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) + + real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel + + real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs),eisw(ngs) + real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs) + real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) + real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) + real ehxr(ngs),ehlr(ngs),egmr(ngs) + real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs) + real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) + real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) + real ehscnv(ngs) + real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) + + real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) + real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs) + real esiclsn(ngs) + + real :: ehs_collsn = 0.5, ehi_collsn = 1.0 + real :: ehls_collsn = 1.0, ehli_collsn = 1.0 + real :: esi_collsn = 1.0 + + real ew(8,6) + real cwr(8,2) ! radius and inverse of interval + data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & ! radius + & 1.0, 1.0, 0.5, 0.5, 0.5, 0.2, 0.2, 1. / ! inverse of interval + integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs) + real grad(6,2) ! graupel radius and inverse of interval + data grad / 100., 200., 300., 400., 600., 1000., & + & 1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1. / +!droplet radius: 2 3 4 6 8 10 15 20 + data ew /0.03, 0.07, 0.17, 0.41, 0.58, 0.69, 0.82, 0.88, & ! 100 +! : 0.07, 0.13, 0.27, 0.48, 0.65, 0.73, 0.84, 0.91, ! 150 + & 0.10, 0.20, 0.34, 0.58, 0.70, 0.78, 0.88, 0.92, & ! 200 + & 0.15, 0.31, 0.44, 0.65, 0.75, 0.83, 0.96, 0.91, & ! 300 + & 0.17, 0.37, 0.50, 0.70, 0.81, 0.87, 0.93, 0.96, & ! 400 + & 0.17, 0.40, 0.54, 0.71, 0.83, 0.88, 0.94, 0.98, & ! 600 + & 0.15, 0.37, 0.52, 0.74, 0.82, 0.88, 0.94, 0.98 / ! 1000 +! : 0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400 + + + real da0lr(ngs) + real da0lh(ngs) + real da0lhl(ngs) + + real va0 (lc:lqmx) ! collection coefficients from Seifert 2005 + real vab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real vab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real va1 (lc:lqmx) ! collection coefficients from Seifert 2005 + real ehip(ngs),ehlip(ngs),ehlir(ngs) + real erir(ngs),esir(ngs),eglir(ngs),egmir(ngs),eghir(ngs) + real efir(ngs),ehir(ngs),eirw(ngs),eirir(ngs),ehr(ngs) + real erip(ngs),esip(ngs),eglip(ngs),eghip(ngs) + real efip(ngs),eipi(ngs),eipw(ngs),eipip(ngs) +! +! arrays for production terms +! + real ptotal(ngs) ! , pqtot(ngs) +! + real pqcwi(ngs),pqcii(ngs),pqrwi(ngs),pqisi(ngs) + real pqswi(ngs),pqhwi(ngs),pqwvi(ngs) + real pqgli(ngs),pqghi(ngs),pqfwi(ngs) + real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) + real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), + real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs) + + real pqlwlghi(ngs),pqlwlghli(ngs) + real pqlwlghd(ngs),pqlwlghld(ngs) + + + + real pvhwi(ngs), pvhwd(ngs) + real pvhli(ngs), pvhld(ngs) + real pvswi(ngs), pvswd(ngs) +! + real pqcwd(ngs),pqcid(ngs),pqrwd(ngs),pqisd(ngs), pqcwdacc(ngs) + real pqswd(ngs),pqhwd(ngs),pqwvd(ngs) + real pqgld(ngs),pqghd(ngs),pqfwd(ngs) + real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) + real pqird(ngs),pqipd(ngs) ! pqwad(ngs), + real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs) +! +! real pqxii(ngs,nhab),pqxid(ngs,nhab) +! + real pctot(ngs) + real pcipi(ngs), pcipd(ngs) + real pciri(ngs), pcird(ngs) + real pccwi(ngs), pccwd(ngs), pccwdacc(ngs) + real pccii(ngs), pccid(ngs) + real pcisi(ngs), pcisd(ngs) + real pccin(ngs) + real pcrwi(ngs), pcrwd(ngs) + real pcswi(ngs), pcswd(ngs) + real pchwi(ngs), pchwd(ngs) + real pchli(ngs), pchld(ngs) + real pcfwi(ngs), pcfwd(ngs) + real pcgli(ngs), pcgld(ngs) + real pcgmi(ngs), pcgmd(ngs) + real pcghi(ngs), pcghd(ngs) + + real pzrwi(ngs), pzrwd(ngs) + real pzhwi(ngs), pzhwd(ngs) + real pzhli(ngs), pzhld(ngs) + real pzswi(ngs), pzswd(ngs) + +! +! other arrays +! + real dqisdt(ngs) !,advisc(ngs) !dqwsdt(ngs), ,schm(ngs),pndl(ngs) + + real qss0(ngs) + + real qsacip(ngs) + real pres(ngs),pipert(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs),sqrtrhovt + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real ptwfzi(ngs),ptimlw(ngs) + real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs),ptem2(ngs) + + real cnostmp(ngs) ! for diagnosed snow intercept +! +! iholef = 1 to do hole filling technique version 1 +! which uses all hydrometerors to do hole filling of all hydrometeors +! iholef = 2 to do hole filling technique version 2 +! which uses an individual hydrometeror species to do hole +! filling of a species of a hydrometeor +! +! iholen = interval that hole filling is done +! + integer iholef + integer iholen + parameter (iholef = 1) + parameter (iholen = 1) + real cqtotn,cqtotn1 + real cctotn + real citotn + real crtotn + real cstotn + real cvtotn + real cftotn + real cgltotn + real cghtotn + real chtotn + real cqtotp,cqtotp1 + real cctotp + real citotp + real ciptotp + real crtotp + real cstotp + real cvtotp + real cftotp + real chltotp + real cgltotp + real cgmtotp + real cghtotp + real chtotp + real cqfac + real ccfac + real cifac + real cipfac + real crfac + real csfac + real cvfac + real cffac + real cglfac + real cghfac + real chfac + + real ssifac, qvapor +! +! Miscellaneous variables +! + integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh + integer lqrw + real vt + real arg ! gamma is a function + real erbnd1, fdgt1, costhe1 + real qeps + real dyi2,dzi2,cp608,bta1,cnit,dragh,dnz00,pii + real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds,gr + real gf1palp(ngs) ! for storing Gamma[1.0 + alphar] + + + real xdn0(lc:lhab) + real xdn_new,drhodt + + integer l ,ltemq,inumgs, idelq + + real brz,arz,temq + + real ssival,tqvcon + real cdx(lc:lhab) + real cnox + real cval,aval,eval,fval,gval ,qsign,ftelwc,qconkq,elecfac,altelecfac + real qconm,qconn,cfce15,gf8,gf4i,gf3p5,gf1a,gf1p5,qdiff,argrcnw + real c4,bradp,bl2,bt2,dthr,hrifac, hdia0,hdia1,civenta,civentb + real civentc,civentd,civente,civentf,civentg,cireyn,xcivent + real cipventa,cipventb,cipventc,cipventd,cipreyn,cirventa + real cirventb + integer igmrwa,igmrwb,igmswa, igmswb,igmfwa,igmfwb,igmhwa,igmhwb + real rwventa ,rwventb,swventa,swventb,fwventa,fwventb,fwventc + real hwventa,hwventb + real hwventc, hlventa, hlventb, hlventc + real glventa, glventb, glventc + real gmventa, gmventb, gmventc, ghventa, ghventb, ghventc + real dzfacp, dzfacm, cmassin, cwdiar + real rimmas, rhobar + real argtim, argqcw, argqxw, argtem + real frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1 + real frcglgl, frcglgm, frcglgh, frcglfw, frcglgl1 + real frcgmgl, frcgmgm, frcgmgh, frcgmfw, frcgmgm1 + real frcghgl, frcghgm, frcghgh, frcghfw, frcghgh1 + real frcfwgl, frcfwgm, frcfwgh, frcfwfw, frcfwfw1 + real frcswrsw, frcswrgl, frcswrgm, frcswrgh, frcswrfw + real frcswrsw1 + real frcrswsw, frcrswgl, frcrswgm, frcrswgh, frcrswfw + real frcrswsw1 + real frcglrgl, frcglrgm, frcglrgh, frcglrfw, frcglrgl1 + real frcrglgl + real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 + real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 + real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 + real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt + real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl + real frcrghgm, frcrghgh, frcrghfw, frcrghgh1 + real a1,a2,a3,a4,a5,a6 + real gamss + real cdw, cdi, denom1, denom2, delqci1, delqip1 + real cirtotn, ciptotn, cgmtotn, chltotn, cirtotp + real cgmfac, chlfac, cirfac + integer igmhla, igmhlb, igmgla, igmglb, igmgma, igmgmb + integer igmgha, igmghb + integer idqis, item, itim0 + integer iqgl, iqgm, iqgh, iqrw, iqsw + integer itertd, ia + + integer :: infdo + + real tau, ewtmp + + integer cntnic_noliq + real q_noliqmn, q_noliqmx + real scsacimn, scsacimx + + real :: dtpinv + +! arrays for temporary bin space + + real :: xden,xmlt,cmlt,cmlttot,fventm,fventh,am,ah,felfinv,dmwdt + + real :: qhmlrtmp,qhmlrtmp2, chmlrtmp, chmlrtmpd1inf, chlmlrtmp, zhlmlrtmp, zhlmlrrtmp, qvs0,tmpcmlt + + real :: term1,term2,term3,term4 + real :: qaacw ! combined qsacw-qhacw for WSM6 variation + + + +! +! #################################################################### +! +! Start routine +! +! #################################################################### + + + +! + + pb(:) = 0.0 + pinit(:) = 0.0 + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + istag = 0 + jstag = 0 + kstag = 1 + + + +! +! slope intercepts +! + + IF ( ngs .lt. nz ) THEN +! write(0,*) 'Error in ICEZVD: Must have ngs .ge. nz!' +! STOP + ENDIF + + cntnic_noliq = 0 + q_noliqmn = 0.0 + q_noliqmx = 0.0 + scsacimn = 0.0 + scsacimx = 0.0 + + ldovol = .false. + + DO il = lc,lhab + ldovol = ldovol .or. ( lvol(il) .gt. 1 ) + ENDDO + + +! DO il = lc,lhab +! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) +! ENDDO + +! +! density maximums and minimums +! + +! +! Set terminal velocities... +! also set drag coefficients +! + + dtpinv = 1.d0/dtp + +! + +! +! electricity constants +! +! mixing ratio epsilon +! + qeps = 1.0e-20 + +! rebound efficiency (erbnd) +! +! +! +! constants +! + + cp608 = 0.608 + aradcw = -0.27544 + bradcw = 0.26249e+06 + cradcw = -1.8896e+10 + dradcw = 4.4626e+14 + bta1 = 0.6 + cnit = 1.0e-02 + dragh = 0.60 + dnz00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + pii = piinv ! 1./pi + pid4 = pi/4.0 +! qscrit = 6.0e-04 + gf1 = 1.0 ! gamma(1.0) + gf1p5 = 0.8862269255 ! gamma(1.5) + gf2 = 1.0 ! gamma(2.0) + gf3 = 2.0 ! gamma(3.0) + gf3p5 = 3.32335097 ! gamma(3.5) + gf4 = 6.00 ! gamma(4.0) + gf5 = 24.0 ! gamma(5.0) + gf6 = 120.0 ! gamma(6.0) + gf7 = 720.0 ! gamma(7.0) + gf4br = 17.837861981813607 ! gamma(4.0+br) + gf4ds = 10.41688578110938 ! gamma(4.0+ds) + gf4p5 = 11.63172839656745 ! gamma(4.0+0.5) + gf3ds = 3.0458730354120997 ! gamma(3.0+ds) + gf1ds = 0.8863557896089221 ! gamma(1.0+ds) + gr = 9.8 + gf43rds = 0.8929795116 ! gamma(4./3.) + gf53rds = 0.9027452930 ! gamma(5./3.) + gf73rds = 1.190639349 ! gamma(7./3.) + gf83rds = 1.504575488 ! gamma(8./3.) + + gamice73fac = (Gamma_sp(7./3. + cinu))**3/ (Gamma_sp(1. + cinu)**3 * (1. + cinu)**4) + gamsnow73fac = (Gamma_sp(7./3. + snu))**3/ (Gamma_sp(1. + snu)**3 * (1. + snu)**4) + +! gcnup1 = Gamma_sp(cnu + 1.) +! gcnup2 = Gamma_sp(cnu + 2.) +! +! constants +! +! +! general constants for microphysics +! + brz = 100.0 + arz = 0.66 + + bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/ & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)) + + galpharaut = (6.+alpharaut)*(5.+alpharaut)*(4.+alpharaut)/ & + & ((3.+alpharaut)*(2.+alpharaut)*(1.+alpharaut)) + + vfrz = 0.523599*(dfrz)**3 + vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) + vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) + + snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + + tdtol = 1.0e-05 + tfrcbw = tfr - cbw + tfrcbi = tfr - cbi +! +! +! #ifdef COMMAS +! print*,'ventr,ventc = ',ventr,ventc + +! +! Set up look up tables for supersaturation w.r.t. liq and ice +! +!VD$L SKIP +! do l = 1,nqsat +! temq = 163.15 + (l-1)*fqsat +! tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) +! tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) +! end do + + mltmass0inv = 1.0/( 1000.0* xvmx(lr) ) ! for drops melting from ice with diameter > 1.9cm + mltmass1inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize1)**3) ) ! for drops melting from ice with diameter > 1.9cm; 0.01 converts cm to m, 0.5 conv. diam to radius + mltmass2inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize2)**3) ) ! for drops melting from ice with 0.9cm < d < 1.9cm (or 1.6cm to 1.9cm) + mltmass3inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize3)**3) ) ! for drops melting from ice with 0.9cm < d < 1.6cm + mltmass1cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize1)**3) + mltmass2cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize2)**3) + mltmass3cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize3)**3) + +! real, parameter :: mltdiam1 = 9.0e-3, mltdiam2 = 19.0e-3, mltdiam05 = 4.5e-3 + + IF ( ibinnum == 1 ) THEN + numdiam = 1 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 4.5e-3 + ELSEIF ( ibinnum == 2 ) THEN + numdiam = 2 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = mltdiam1/6. ! 1.5e-3 + mltdiam(2) = mltdiam1/2. ! 4.5e-3 + ELSEIF ( ibinnum > 2 ) THEN + numdiam = Min(ibinnum, ndiam) + DO k = 1,numdiam + mltdiam(k) = (k - 0.5)*mltdiam1/float(numdiam) + ENDDO + + ELSE + numdiam = 5 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 0.5e-3 + mltdiam(2) = 1.0e-3 + mltdiam(3) = 2.0e-3 + mltdiam(4) = 4.0e-3 + mltdiam(5) = 6.0e-3 + ENDIF + + + IF ( numshedregimes == 2 ) THEN + mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3 + mltdiam(ndiam+2) = mltdiam3 ! 19.0e-3 + mltdiam(ndiam+3) = mltdiam4 !100.0e-3 + ELSEIF ( numshedregimes == 3 ) THEN + mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3 + mltdiam(ndiam+2) = mltdiam2 ! 16.0e-3 + mltdiam(ndiam+3) = mltdiam3 ! 19.0e-3 + mltdiam(ndiam+4) = mltdiam4 !200.0e-3 + ENDIF + + kzb = 1 + kze = ktile +! if (kzend .eq. nzend) kze = kzend-kzbeg+1-kstag + +! +! cw constants in mks units +! +! cwmasn = 4.25e-15 ! radius of 1.0e-6 + mwfac = 6.0**(1./3.) + IF ( ipconc .ge. 2 ) THEN +! cwmasn = xvmn(lc)*1000. +! cwradn = 1.0e-6 +! cwmasx = xvmx(lc)*1000. + ENDIF + rwmasn = xvmn(lr)*1000. + rwmasx = xvmx(lr)*1000. + +! +! ci constants in mks units +! + cimasn = Min(cimas0, cimas1) ! 12 microns for 0.1871*(xmas(mgs,li)**(0.3429)) + cimasx = 1.0e-8 ! 338 microns + ccimx = 5000.0e3 ! max of 5000 per liter + +! +! constants for paramerization +! +! +! set save counter (number of saves): nsvcnt +! +! nsvcnt = 0 + iend = 0 + + +! timetd1 = etime(tarray) +! timetd1 = tarray(1) + +! +!*********************************************************** +! start jy loop +!*********************************************************** +! + +! do 9999 jy = 1,ny-jstag +! +! VERY IMPORTANT: SET jy = jgs +! + jy = jgs + + +! t1(:,:,:) = 0 +! t2(:,:,:) = 0 +! t3(:,:,:) = 0 +! t4(:,:,:) = 0 +! t5(:,:,:) = 0 +! t6(:,:,:) = 0 +! t8(:,:,:) = 0 + + IF ( ipconc < 2 ) THEN ! Make a copy of cloud droplet mixing ratio to use for homogeneous freezing + DO kz = 1,kze + DO ix = 1,itile + t9(ix,jy,kz) = an(ix,jy,kz,lc) + ENDDO + ENDDO + ENDIF + +! +!..Gather microphysics +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE' + + + + nxmpb = 1 + nzmpb = 1 + nxz = itile*nz + numgs = nxz/ngs + 1 +! write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE: nx,nz,nxz,numgs,ngs = ',nx,nz,nxz,numgs,ngs + + do 1000 inumgs = 1,numgs + ngscnt = 0 + + do kz = nzmpb,kze + do ix = nxmpb,itile + + pqs(1) = t00(ix,jy,kz) +! pqs(kz) = t00(ix,jy,kz) + + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) + temcg(1) = temg(1) - tfr + tqvcon = temg(1)-cbw + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) + + qss(1) = qvs(1) + +! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN +! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz) +! ENDIF + + if ( temg(1) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) + qss(1) = qis(1) + else +! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN +! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz) +! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz)) +! ENDIF + end if +! + ishail = .false. + IF ( lhl > 1 ) THEN + IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) ishail = .true. + ENDIF + + if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & an(ix,jy,kz,li) .gt. qxmin(li) .or. & + & an(ix,jy,kz,lr) .gt. qxmin(lr) .or. & + & an(ix,jy,kz,ls) .gt. qxmin(ls) .or. & + & an(ix,jy,kz,lh) .gt. qxmin(lh) .or. ishail ) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if + enddo !ix + nxmpb = 1 + enddo !kz + 1100 continue + + if ( ngscnt .eq. 0 ) go to 9998 + + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5' + +! write(0,*) 'allocating qc' + + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + vtxbar(:,:,:) = 0.0 + xdia(:,:,:) = 0.0 + raindn(:,:) = 900. + cx(:,:) = 0.0 + alpha(:,:) = 0.0 + DO il = li,lhab + DO mgs = 1,ngscnt + rimdn(mgs,il) = rimedens ! xdn0(il) + ENDDO + ENDDO +! +! define temporaries for state variables to be used in calculations +! + do mgs = 1,ngscnt + kgsm(mgs) = max(kgs(mgs)-1,1) + kgsp(mgs) = min(kgs(mgs)+1,nz-1) + kgsm2(mgs) = Max(kgs(mgs)-2,1) + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs) + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = an(igs(mgs),jy,kgs(mgs),lv) + qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv) - qv0(mgs) ! qv0(mgs) is full qv, so qwvp starts as zero! + + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/rho0(mgs)) + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs)) + temgkm2(mgs) = t0(igs(mgs),jy,kgsm2(mgs)) + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + qss(mgs) = qvs(mgs) +! es(mgs) = 6.1078e2*tabqvs(ltemq) +! eis(mgs) = 6.1078e2*tabqis(ltemq) + cnostmp(mgs) = cno(ls) +! + + il5(mgs) = 0 + if ( temg(mgs) .lt. tfr ) then + il5(mgs) = 1 + end if + enddo !mgs + + IF ( ipconc < 1 .and. lwsm6 ) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF + + +! +! zero arrays that are used but not otherwise set (tm) +! + do mgs = 1,ngscnt + qhshr(mgs) = 0.0 + end do +! +! set temporaries for microphysics variables +! + DO il = lv,lhab + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + end do + + qxw(:,:) = 0.0 + qxwlg(:,:) = 0.0 + + + + scx(:,:) = 0.0 +! +! set shape parameters +! + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + alpha(:,li) = xnu(li) + alpha(:,lc) = xnu(lc) + + IF ( imusnow == 1 ) THEN + alpha(:,ls) = alphas + ELSEIF ( imusnow == 3 ) THEN + alpha(:,ls) = xnu(ls) + ENDIF + + DO il = lc,lhab + do mgs = 1,ngscnt + IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) + DO ic = lr,lhab + dab0lh(mgs,il,ic) = dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(ic,il) + ENDDO + ENDDO + end do + + +! DO mgs = 1,ngscnt + da0lh(:) = da0(lh) + da0lr(:) = da0(lr) + IF ( lzh < 1 .or. lzhl < 1 ) THEN + rzxhlh(:) = rzhl/rz + ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN + rzxhlh(:) = 1. + ENDIF + IF ( lzr > 1 ) THEN + rzxh(:) = 1. + rzxhl(:) = 1. + ELSE + rzxh(:) = rz + rzxhl(:) = rzhl + ENDIF + + IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN + rzxs(:) = rzs + ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN + rzxs(:) = 1. + ENDIF + ! ENDDO + + IF ( lhl .gt. 1 ) THEN + DO mgs = 1,ngscnt + da0lhl(mgs) = da0(lhl) + ENDDO + ENDIF + + ventrx(:) = ventr + ventrxn(:) = ventrn + gf1palp(:) = gamma_sp(1.0 + alphar) + +! +! set concentrations +! +! ssmax = 0.0 + + + + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + IF ( lcina .gt. 1 ) THEN + cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) + ELSE + cina(mgs) = cx(mgs,li) + ENDIF + IF ( lcin > 1 ) THEN + ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin) + ENDIF + end do + end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + IF ( lss > 1 ) THEN + ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) + ENDIF + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = 0.0 + ENDIF + IF ( lccna .gt. 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) + ELSE + ccna(mgs) = cx(mgs,lc) + ENDIF + end do +! ELSE +! cx(mgs,lc) = Abs(ccn) + end if + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! cx(mgs,lr) = 0.0 + ELSEIF ( cx(mgs,lr) .eq. 0.0 .and. qx(mgs,lr) .lt. 3.0*qxmin(lr) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lr) + qx(mgs,lr) = 0.0 + ELSE + cx(mgs,lr) = Max( 1.e-9, cx(mgs,lr) ) + ENDIF + end do + end if + if ( ipconc .ge. 4 ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) + IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! cx(mgs,ls) = 0.0 + ELSEIF ( cx(mgs,ls) .eq. 0.0 .and. qx(mgs,ls) .lt. 3.0*qxmin(ls) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,ls) + qx(mgs,ls) = 0.0 + ELSE + cx(mgs,ls) = Max( 1.e-9, cx(mgs,ls) ) + + IF ( ilimit .ge. ipc(ls) ) THEN + tmp = (xdn0(ls)*cx(mgs,ls))/(rho0(mgs)*qx(mgs,ls)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,ls)*(tmp2) + IF ( cnox .gt. 3.0*cno(ls) ) THEN + cx(mgs,ls) = 3.0*cno(ls)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 5 ) then + do mgs = 1,ngscnt + + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) + IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! cx(mgs,lh) = 0.0 + ELSEIF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) + qx(mgs,lh) = 0.0 + ELSE + cx(mgs,lh) = Max( 1.e-9, cx(mgs,lh) ) + IF ( ilimit .ge. ipc(lh) ) THEN + tmp = (xdn0(lh)*cx(mgs,lh))/(rho0(mgs)*qx(mgs,lh)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lh)*(tmp2) + IF ( cnox .gt. 3.0*cno(lh) ) THEN + cx(mgs,lh) = 3.0*cno(lh)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if + + if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then + do mgs = 1,ngscnt + + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) + IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN + cx(mgs,lhl) = 0.0 + ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) + qx(mgs,lhl) = 0.0 + ELSE + cx(mgs,lhl) = Max( 1.e-9, cx(mgs,lhl) ) + IF ( ilimit .ge. ipc(lhl) ) THEN + tmp = (xdn0(lhl)*cx(mgs,lhl))/(rho0(mgs)*qx(mgs,lhl)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lhl)*(tmp2) + IF ( cnox .gt. 3.0*cno(lhl) ) THEN + cx(mgs,lhl) = 3.0*cno(lhl)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if + +! +! Set mean particle volume +! + IF ( ldovol ) THEN + + vx(:,:) = 0.0 + + DO il = li,lhab + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + ENDDO + + ENDIF + + ENDDO + + ENDIF + + + + + +! +! set factors +! + do mgs = 1,ngscnt +! + ssi(mgs) = qx(mgs,lv)/qis(mgs) + ssw(mgs) = qx(mgs,lv)/qvs(mgs) +! + tsqr(mgs) = temg(mgs)**2 +! + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) +! + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 + +! felf = latent heat of fusion, fels = LH of sublimation, felv = LH of vaporization + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 +! + fels(mgs) = felv(mgs) + felf(mgs) +! + felvs(mgs) = felv(mgs)*felv(mgs) + felss(mgs) = fels(mgs)*fels(mgs) + + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + felscp(mgs) = fels(mgs)*cpi + felfcp(mgs) = felf(mgs)*cpi + ELSE + + ! equations from appendix in Bryan and Morrison (2012, MWR) + ! note that rw is Rv in the paper, and rd is R. + + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + + IF ( eqtset == 2 ) THEN ! compact form from treating dT/dt = theta*d(pi)/dt + pi*d(theta)dt and then applied to theta assuming constant pi + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm + felfcp(mgs) = felf(mgs)/cvm + + ELSE + ! equivalent version that applies separate updates of latent heating to theta and pi, when both are returned. + + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felscp(mgs) = (fels(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felfcp(mgs) = felf(mgs)*cv/(cp*cvm) + + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felspi(mgs) = pi0(mgs)*rovcp*(fels(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felfpi(mgs) = pi0(mgs)*rovcp*(felf(mgs)/(cvm*temg(mgs))) + + ENDIF + + ENDIF +! + fgamw(mgs) = felvcp(mgs)/pi0(mgs) + fgams(mgs) = felscp(mgs)/pi0(mgs) +! + fcqv1(mgs) = 4098.0258*pi0(mgs)*fgamw(mgs) + fcqv2(mgs) = 5807.6953*pi0(mgs)*fgams(mgs) + fcc3(mgs) = felfcp(mgs)/pi0(mgs) +! +! fwvdf = water vapor diffusivity + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)*(101325.0/(pres(mgs))) +! +! fadvisc = 'd' for dynamic viscosity +! fakvisc = 'k' for kinematic viscosity + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))*(temg(mgs)/296.0)**(1.5) ! dynamic visc. +! + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) ! divide by rho_air to get kinematic visc. (note the 'k' vs. 'd') +! + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fci(mgs) = (2.118636 + 0.007371*(temcgx(mgs)))*(1.0e+03) +! + if ( temg(mgs) .lt. 273.15 ) then + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4203.1548 + (1.30572e-2)*((temcgx(mgs)-35.)**2) & + & + (1.60056e-5)*((temcgx(mgs)-35.)**4) + end if + if ( temg(mgs) .ge. 273.15 ) then + temcgx(mgs) = min(temg(mgs),308.15) + temcgx(mgs) = max(temcgx(mgs),273.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4243.1688 + (3.47104e-1)*(temcgx(mgs)**2) + end if +! + ftka(mgs) = tka0*fadvisc(mgs)/advisc1 ! thermal conductivity: proportional to dynamic viscosity + fthdf(mgs) = ftka(mgs)*cpi*rhoinv(mgs) +! + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) ! Schmidt number + fpndl(mgs) = (fakvisc(mgs)/fthdf(mgs)) ! Prandl number (only used for bin melting) +! + fai(mgs) = (fels(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbi(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qis(mgs))) + fav(mgs) = (felv(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbv(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qvs(mgs))) + + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + +! + end do +! +! +! ice habit fractions +! +! +! +! Set density +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set density' +! + + do mgs = 1,ngscnt + xdn(mgs,li) = xdn0(li) + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + xdn(mgs,ls) = xdn0(ls) + xdn(mgs,lh) = xdn0(lh) + IF ( lvol(ls) .gt. 1 ) THEN + IF ( vx(mgs,ls) .gt. 0.0 .and. qx(mgs,ls) .gt. qxmin(ls) ) THEN + xdn(mgs,ls) = Min( xdnmx(ls), Max( xdnmn(ls), rho0(mgs)*qx(mgs,ls)/vx(mgs,ls) ) ) + ENDIF + ENDIF + + IF ( lvol(lh) .gt. 1 ) THEN + IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( mixedphase ) THEN + ELSE + dnmx = xdnmx(lh) + ENDIF + xdn(mgs,lh) = Min( dnmx, Max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) ) + vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) + + ELSEIF ( vx(mgs,lh) == 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN ! if volume is zero, need to initialize the default value + + vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) + + ENDIF + ENDIF + + IF ( lhl .gt. 1 ) THEN + + xdn(mgs,lhl) = xdn0(lhl) + + IF ( lvol(lhl) .gt. 1 ) THEN + IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + + IF ( mixedphase .and. lhlw > 1 ) THEN + ELSE + dnmx = xdnmx(lhl) + ENDIF + + xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + + ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value + + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + + ENDIF + ENDIF + + ENDIF + + + end do + + + IF ( imurain == 3 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 0.0 + alphamlr = -2.0/3.0 + ELSE + alphashr = xnu(lr) + alphamlr = xnu(lr) + ENDIF +! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor +! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) + massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor + massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) + ELSEIF ( imurain == 1 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 4.0 + alphamlr = 4.0 + ELSE + alphashr = alphar + alphamlr = alphar + ENDIF +! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor +! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) + massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor + massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) + ENDIF + + +! +! set some values for ice nucleation +! + do mgs = 1,ngscnt + kp1 = Min(nz, kgs(mgs)+1 ) +! wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & +! & +w(igs(mgs),jgs,kgs(mgs))) + + + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,kgsm(mgs))) + cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) + end do + +! +! Set a couple of cloud variables... +! + +! SUBROUTINE setvt(ngscnt,qx,qxmin,cx,rho0,rhovt,xdia,cno, +! : xmas,xdn,xvmn,xvmx,xv,cdx, +! : ipconc,ndebug) +! SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno, & +! & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & +! & ipconc1,ndebug1,ngs,nz,kgs,cwnccn,fadvisc, & +! & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & +! & itype1a,itype2a,temcg,infdo,alpha) + + + infdo = 0 + IF ( rimdenvwgt > 0 ) infdo = 1 + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebug,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) + + + IF ( lwsm6 .and. ipconc == 0 ) THEN + tmp = Max(qxmin(lh), qxmin(ls)) + DO mgs = 1,ngscnt + sum = qx(mgs,lh) + qx(mgs,ls) + IF ( sum > tmp ) THEN + vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum + ELSE + vt2ave(mgs) = 0.0 + ENDIF + ENDDO + ENDIF + + +! +! Set number concentrations (need xdia from setvt) +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration' + IF ( ipconc .lt. 1 ) THEN + cina(1:ngscnt) = cx(1:ngscnt,li) + ENDIF + if ( ipconc .lt. 5 ) then + do mgs = 1,ngscnt + + + IF ( ipconc .lt. 3 ) THEN +! cx(mgs,lr) = 0.0 + if ( qx(mgs,lr) .gt. qxmin(lh) ) then +! cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) +! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + end if + ENDIF + + IF ( ipconc .lt. 4 ) THEN +! tmp = cx(mgs,ls) +! cx(mgs,ls) = 0.0 + if ( qx(mgs,ls) .gt. qxmin(ls) ) then +! cx(mgs,ls) = cno(ls)*xdia(mgs,ls,1) +! xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + end if + ENDIF ! ( ipconc .lt. 4 ) + + IF ( ipconc .lt. 5 ) THEN + + +! cx(mgs,lh) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then +! cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) +! xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) +! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + + ENDIF ! ( ipconc .lt. 5 ) + + end do + end if + + IF ( ipconc .ge. 2 ) THEN + DO mgs = 1,ngscnt + + rb(mgs) = 0.5*xdia(mgs,lc,1)*((1./(1.+alpha(mgs,lc))))**(1./6.) + xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & + & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) + IF ( rb(mgs) .gt. 3.51e-6 ) THEN +! rh(mgs) = Max( 0.5d0*xdia(mgs,lc,1), 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + rh(mgs) = Max( 41.d-6, 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + ELSE + rh(mgs) = 41.d-6 + ENDIF + IF ( xl2p(mgs) .gt. 0.0 ) THEN + nh(mgs) = 4.2d9*xl2p(mgs) + ELSE + nh(mgs) = 1.e30 + ENDIF + ENDDO + ENDIF + +! +! +! +! +! maximum depletion tendency by any one source +! +! + if( ndebug .ge. 0 ) THEN +!mpi! write(0,*) 'Set depletion max/min1' + endif + do mgs = 1,ngscnt + qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))*dtpinv ! depletion by all vap. dep to ice. + + IF ( qx(mgs,lc) < qxmin(lc) ) qvimxd(mgs) = 0.99*(qx(mgs,lv)-qis(mgs))*dtpinv ! this makes virtually no difference whatsoever, but what the heck + + qvimxd(mgs) = max(qvimxd(mgs), 0.0) + + frac = 0.1d0 + qimxd(mgs) = frac*qx(mgs,li)*dtpinv + qcmxd(mgs) = frac*qx(mgs,lc)*dtpinv + qrmxd(mgs) = frac*qx(mgs,lr)*dtpinv + qsmxd(mgs) = frac*qx(mgs,ls)*dtpinv + qhmxd(mgs) = frac*qx(mgs,lh)*dtpinv + IF ( lhl > 1 ) qhlmxd(mgs) = frac*qx(mgs,lhl)*dtpinv + end do +! + if( ndebug .ge. 0 ) THEN +!mpi! write(0,*) 'Set depletion max/min2' + endif + + do mgs = 1,ngscnt +! + if ( qx(mgs,lc) .le. qxmin(lc) ) then + ccmxd(mgs) = 0.20*cx(mgs,lc)*dtpinv + else + IF ( ipconc .ge. 2 ) THEN + ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv + ELSE + ccmxd(mgs) = frac*qx(mgs,lc)/(xmas(mgs,lc)*rho0(mgs)*dtp) + ENDIF + end if +! + if ( qx(mgs,li) .le. qxmin(li) ) then + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + else + IF ( ipconc .ge. 1 ) THEN + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + ELSE + cimxd(mgs) = frac*qx(mgs,li)/(xmas(mgs,li)*rho0(mgs)*dtp) + ENDIF + end if +! +! + crmxd(mgs) = 0.10*cx(mgs,lr)*dtpinv + csmxd(mgs) = frac*cx(mgs,ls)*dtpinv + chmxd(mgs) = frac*cx(mgs,lh)*dtpinv + + ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + crmxd(mgs) = frac*cx(mgs,lr)*dtpinv + csmxd(mgs) = frac*cx(mgs,ls)*dtpinv + chmxd(mgs) = frac*cx(mgs,lh)*dtpinv + + qxmxd(mgs,lv) = Max(0.0, 0.1*(qx(mgs,lv) - qvs(mgs))*dtpinv) + + DO il = lc,lhab + qxmxd(mgs,il) = frac*qx(mgs,il)*dtpinv + cxmxd(mgs,il) = frac*cx(mgs,il)*dtpinv + ENDDO + + end do + + + + + + + + + ! default factors between mean volume and maximum mass volume + maxmassfac(lc) = ( (2. + 3.*(1. + xnu(lc)) )**3/( 3.*(1. + xnu(lc)) ) ) + maxmassfac(li) = ( (2. + 3.*(1. + xnu(li)) )**3/( 3.*(1. + xnu(li)) ) ) + + IF ( imurain == 3 ) THEN + maxmassfac(lr) = ( (2. + 3.*(1. + xnu(lr)) )**3/( 3.*(1. + xnu(lr)) ) ) + ELSE + maxmassfac(lr) = (3.0 + alphar)**3/ & + & ((3.+alphar)*(2.+alphar)*(1. + alphar) ) + ENDIF + + IF ( imusnow == 3 ) THEN + maxmassfac(ls) = ( (2. + 3.*(1. + alphas) )**3/( 3.*(1. + alphas) ) ) + ELSE + maxmassfac(ls) = (3.0 + alphas)**3/ & + & ((3.+alphas)*(2.+alphas)*(1. + alphas) ) + ENDIF + + maxmassfac(lh) = (3.0 + alphah)**3/ & + & ((3.+alphah)*(2.+alphah)*(1. + alphah) ) + + IF ( lhl > 1 ) THEN + maxmassfac(lhl) = (3.0 + alphahl)**3/ & + & ((3.+alphahl)*(2.+alphahl)*(1. + alphahl) ) + ENDIF + + + + DO mgs = 1,ngscnt + DO il = lh,lhab ! graupel and hail only + + vshdgs(mgs,il) = vshd ! base value + + IF ( qx(mgs,il) > qxmin(il) ) THEN + + ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter. + tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + + IF ( tmpdiam > sheddiam0 ) THEN + vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice + ELSEIF ( tmpdiam > sheddiam ) THEN ! intermediate size + vshdgs(mgs,il) = 0.523599*(3.0e-3)**3/massfacshr ! 3.0mm drops from medium-large ice + ELSE +! vshdgs(mgs,il) = Min( xvmx(lr), xv(mgs,il)*xdn(mgs,il)*0.001 ) ! size of drop from melted mean ice particle + vshdgs(mgs,il) = Min( xvmx(lr), 6./pi*xdn(mgs,il)*0.001*tmpdiam**3 )/massfacshr ! size of drop from melted mean ice particle; 0.001 is 1/rhow + ENDIF + ENDIF + ENDDO + ENDDO + +! +! +! microphysics source terms (1/s) for mixing ratios +! +! +! +! Collection efficiencies: +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies' +! + do mgs = 1,ngscnt +! +! +! + qcwresv(mgs) = 0.0 + ccwresv(mgs) = 0.0 + + erw(mgs) = 0.0 + esw(mgs) = 0.0 + ehw(mgs) = 0.0 + ehlw(mgs) = 0.0 +! ehxw(mgs) = 0.0 +! + err(mgs) = 0.0 + esr(mgs) = 0.0 + il2(mgs) = 0 + il3(mgs) = 0 + ehr(mgs) = 0.0 + ehlr(mgs) = 0.0 +! ehxr(mgs) = 0.0 +! + eri(mgs) = 0.0 + esi(mgs) = 0.0 + ehi(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn + ehis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn + ehli(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn + ehlis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn +! ehxi(mgs) = 0.0 +! + ers(mgs) = 0.0 + ess(mgs) = 0.0 + ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn + ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn + ehscnv(mgs) = 0.0 +! ehxs(mgs) = 0.0 +! + eiw(mgs) = 0.0 + eii(mgs) = 0.0 + + ehsclsn(mgs) = 0.0 + ehiclsn(mgs) = 0.0 + ehlsclsn(mgs) = 0.0 + ehliclsn(mgs) = 0.0 + esiclsn(mgs) = 0.0 + + +! reserve droplets + IF ( exwmindiam > 0 .and. qx(mgs,lc) > qxmin(lc) ) THEN + tmp = cx(mgs,lc)*Exp(- (exwmindiam/xdia(mgs,lc,1))**3 ) + ccwresv(mgs) = Min( cx(mgs,lc), Max( 2.e6, cx(mgs,lc) - tmp ) ) + + tmp = cx(mgs,lc) - ccwresv(mgs) + + volt = pi/6.*(exwmindiam)**3 + qcwresv(mgs) = qx(mgs,lc) - tmp*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + + + IF ( .false. .and. qx(mgs,lc) > 0.1e-3 ) THEN + + write(0,*) 'cx,qx,crsv,qrsv = ',cx(mgs,lc),qx(mgs,lc),ccwresv(mgs),qcwresv(mgs) + + ENDIF + + ENDIF + + + icwr(mgs) = 1 + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + DO il = 1,8 + IF ( cwrad .ge. 1.e-6*cwr(il,1) ) icwr(mgs) = il + ENDDO + ENDIF + + + irwr(mgs) = 1 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) irwr(mgs) = il + ENDDO + ENDIF + + + igwr(mgs) = 1 +! IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN +! rwrad = 0.5*xdia(mgs,lr,1) +! setting erw = 1 always, so now use igwr for graupel + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) igwr(mgs) = il + ENDDO + ENDIF + + IF ( lhl .gt. 1 ) THEN ! hail is turned on + ihlr(mgs) = 1 + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) ihlr(mgs) = il + ENDDO + ENDIF + ENDIF + +! +! +! Ice-Ice: Collection (cxc) efficiencies +! +! + if ( qx(mgs,li) .gt. qxmin(li) ) then +! IF ( ipconc .ge. 14 ) THEN +! eii(mgs)=0.1*exp(0.1*temcg(mgs)) +! if ( temg(mgs) .lt. 243.15 .and. qx(mgs,lc) .gt. 1.e-6 ) then +! eii(mgs)=0.1 +! end if +! +! ELSE + eii(mgs) = exp(0.025*Min(temcg(mgs),0.0)) ! alpha1 from LFO83 (21) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) eii(mgs) = 1.0 + end if +! +! +! +! Ice-cloud water: Collection (cxc) efficiencies +! +! + eiw(mgs) = 0.0 + if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then + + + if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then +! erm 5/10/2007 test following change: +! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then + eiw(mgs) = 0.5 + end if + if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 + end if + +! +! +! +! Rain: Collection (cxc) efficiencies +! +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lc).gt.qxmin(lc) ) then + + IF ( lnr .gt. 1 ) THEN + erw(mgs) = 1.0 + + ELSE + +! cwrad = 0.5*xdia(mgs,lc,1) +! erw(mgs) = +! > min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! IF ( xdia(mgs,lc,1) .lt. 2.4e-06 .or. xdia(mgs,lr,1) .le. 50.0e-6 ) THEN +! erw(mgs)=0.0 +! ENDIF +! erw(mgs) = ew(icwr(mgs),igwr(mgs)) +! interpolate along droplet radius + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = irwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,3) + rwrad = 0.5*xdia(mgs,lr,3) + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + erw(mgs) = Max(0.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) )) + +! write(iunit,*) 'erw: ',erw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + + erw(mgs) = Max(0.0, erw(mgs) ) + IF ( rwrad .lt. 50.e-6 ) THEN + erw(mgs) = 0.0 + ELSEIF ( rwrad .lt. 100.e-6 ) THEN ! linear change from zero at 50 to erw at 100 microns + erw(mgs) = erw(mgs)*(rwrad - 50.e-6)/50.e-6 + ENDIF + + ENDIF + end if + IF ( cx(mgs,lc) .le. 0.0 ) erw(mgs) = 0.0 +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr).gt.qxmin(lr) ) then + err(mgs)=1.0 + end if +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,ls).gt.qxmin(ls) ) then + ers(mgs)=1.0 + end if +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,li).gt.qxmin(li) ) then +! IF ( vtxbar(mgs,lr,1) .gt. vtxbar(mgs,li,1) .and. +! : xdia(mgs,lr,3) .gt. 200.e-6 .and. xdia(mgs,li,3) .gt. 100.e-6 ) THEN + eri(mgs) = eri0 +! cwrad = 0.5*xdia(mgs,li,3) +! eri(mgs) = +! > 1.0*min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! ENDIF +! if ( xdia(mgs,li,1) .lt. 10.e-6 ) eri(mgs)=0.0 + if ( xdia(mgs,li,3) .lt. eri_cimin ) eri(mgs)=0.0 + end if +! +! +! Snow aggregates: Collection (cxc) efficiencies +! +! Modified by ERM with a linear function for small droplets and large +! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997 (Fig. 14-13), which +! allows collection of very small droplets, albeit at low efficiency. But slow +! fall speeds of snow make up for the efficiency. +! + esw(mgs) = 0.0 + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lc).gt.qxmin(lc) ) then + esw(mgs) = 0.5 + if ( xdia(mgs,lc,1) .gt. 15.e-6 .and. xdia(mgs,ls,1) .gt. 100.e-6) then + esw(mgs) = 0.5 + ELSEIF ( xdia(mgs,ls,1) .ge. 500.e-6 ) THEN + esw(mgs) = Min(0.5, 0.05 + (0.8-0.05)/(40.e-6)*xdia(mgs,lc,1) ) + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lr).gt.qxmin(lr) & + & .and. temg(mgs) .lt. tfr - 1. & + & ) then + esr(mgs)=Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,ls,1)) + IF ( qx(mgs,ls) < 1.e-4 .and. qx(mgs,lr) < 1.e-4 ) il2(mgs) = 1 + end if + + IF ( ipconc < 3 .and. temg(mgs) < tfr .and. qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr) < 1.e-4 ) THEN + il3(mgs) = 1 + ENDIF +! +! if ( qx(mgs,ls).gt.qxmin(ls) ) then + if ( temcg(mgs) < 0.0 ) then + + IF ( ipconc .lt. 4 .or. temcg(mgs) < esstem1 ) THEN + ess(mgs) = 0.0 +! ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) +! ess(mgs)=min(0.1,ess(mgs)) + + ELSE + + fac = Abs(ess0) + IF ( .true. .and. ess0 < 0.0 ) THEN +! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN + IF ( wvel(mgs) > 2.0 ) THEN + ! assume convective cell or downdraft + fac = 0.0 + ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values + fac = Max(0.0, 2.0 - wvel(mgs))*fac + ENDIF + ENDIF + + IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25 + ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2 + ELSEIF ( temcg(mgs) >= esstem2 ) THEN + ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) ) + ENDIF + + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,li).gt.qxmin(li) ) then + esiclsn(mgs) = esi_collsn +! IF ( ipconc .lt. 4 ) THEN + IF ( ipconc < 1 .and. lwsm6 ) THEN + esi(mgs) = exp(0.7*min(temcg(mgs),0.0)) + ELSE + esi(mgs) = esi0*exp(0.1*min(temcg(mgs),0.0)) + esi(mgs) = Min(0.1,esi(mgs)) + ENDIF + IF ( ipconc .le. 3 ) THEN + esi(mgs) = exp(0.025*min(temcg(mgs),0.0)) ! LFO +! esi(mgs) = Min(0.5, exp(0.025*min(temcg(mgs),0.0)) ) ! LFO +! esi(mgs)=0.5*exp(0.1*min(temcg(mgs),0.0)) ! 10ice + ENDIF +! ELSE ! zrnic/ziegler 1993 +! esi(mgs)= 0.1 ! 0.5*exp(0.1*min(temcg(mgs),0.0)) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0 + end if +! +! +! +! +! Graupel: Collection (cxc) efficiencies +! +! + xmascw(mgs) = xmas(mgs,lc) + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc).gt.qxmin(lc) ) then !{ + ehw(mgs) = 1.0 + IF ( iehw .eq. 0 ) THEN + ehw(mgs) = ehw0 ! default value is 1.0 + ELSEIF ( iehw .eq. 1 .or. iehw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehw(mgs) = Min( ehw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) + + ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = igwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) ) + ehw(mgs) = Min( ehw(mgs), tmp ) + +! write(iunit,*) 'ehw: ',ehw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehw(mgs) = ehw(mgs) + (1.0 - ehw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + + ELSEIF ( iehw .eq. 3 .or. iehw .eq. 10 ) THEN ! use fraction of droplets greater than dmincw diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + xmascw(mgs) = xmas(mgs,lc) + xdn0(lc)*(pi*dmincw**3/6.0) ! this is the average mass of the droplets with d > dmincw + ehw(mgs) = Min( ehw(mgs), tmp ) + ELSEIF ( iehw .eq. 4 .or. iehw .eq. 10 ) THEN ! Cober and List 1993, eq. 19-20 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lh,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lh,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehw(mgs) = Min( ehw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0 + + ehw(mgs) = Min( ehw0, ehw(mgs) ) + + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehw(mgs) = 0.0 + ENDIF + + end if !} +! + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then +! ehr(mgs) = Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,lh,1)) +! ehr(mgs) = 1.0 + ehr(mgs) = Exp(-(40.e-6)/xdia(mgs,lr,3))*Exp(-40.e-6/xdia(mgs,lh,3)) + ehr(mgs) = Min( ehr0, ehr(mgs) ) + end if +! + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! for 2-moment, used as default for ehs and ehls. Otherwise not used for snow->graupel conversion + ELSE + ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) + ENDIF + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then + ehsclsn(mgs) = ehs_collsn + IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN + ehsclsn(mgs) = 0.0 + ELSEIF ( xdia(mgs,ls,3) < 150.e-6 ) THEN + ehsclsn(mgs) = ehs_collsn*(xdia(mgs,ls,3) - 40.e-6)/(150.e-6 - 40.e-6) + ELSE + ehsclsn(mgs) = ehs_collsn + ENDIF +! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density + ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density + ehs(mgs) = Min(ehs(mgs),ehsmax) + IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0 + end if + ENDIF +! + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,li).gt.qxmin(li) ) then + ehiclsn(mgs) = ehi_collsn + ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 + end if + + IF ( lis > 1 ) THEN + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lis).gt.qxmin(lis) ) then + ehisclsn(mgs) = ehi_collsn + ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 + end if + ENDIF + + +! +! +! Hail: Collection (cxc) efficiencies +! +! + IF ( lhl .gt. 1 ) THEN + + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lc).gt.qxmin(lc) ) then + IF ( iehw == 3 ) iehlw = 3 + IF ( iehw == 4 ) iehlw = 4 + ehlw(mgs) = ehlw0 + IF ( iehlw .eq. 0 ) THEN + ehlw(mgs) = ehlw0 ! default value is 1.0 + ELSEIF ( iehlw .eq. 1 .or. iehlw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehlw(mgs) = Min( ehlw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) + + ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = ihlr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + + x1 = ew(ic, ir) + slope1*(cwrad - cwr(ic,1)) + x2 = ew(icp1,ir) + slope2*(cwrad - cwr(ic,1)) + + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) ) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehlw(mgs) = ehlw(mgs) + (1.0 - ehlw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + + ELSEIF ( iehlw .eq. 3 .or. iehlw .eq. 10 ) THEN ! use fraction of droplets greater than 15 micron diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ELSEIF ( iehlw .eq. 4 .or. iehlw .eq. 10 ) THEN ! Cober and List 1993 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lhl,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lhl,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehlw(mgs) = Min( ehlw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0 + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) + + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehlw(mgs) = 0.0 + ENDIF + + end if +! + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then + ehlr(mgs) = 1.0 + ehlr(mgs) = Min( ehlr0, ehlr(mgs) ) + end if +! + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + if ( qx(mgs,lhl).gt.qxmin(lhl) ) then + ehlsclsn(mgs) = ehls_collsn + ehls(mgs) = ehscnv(mgs) + ehls(mgs) = Min(ehls(mgs),ehsmax) + end if + ENDIF +! + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,li).gt.qxmin(li) ) then + ehliclsn(mgs) = ehli_collsn + ehli(mgs)=eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) + ehli(mgs) = Min( ehimax, Max( ehli(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehli(mgs) = 0.0 + end if + + IF ( lis > 1 ) THEN + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lis).gt.qxmin(lis) ) then + ehlisclsn(mgs) = ehli_collsn + ehlis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehlis(mgs) = Min( ehimax, Max( ehlis(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehlis(mgs) = 0.0 + end if + ENDIF + + + ENDIF ! lhl .gt. 1 + + ENDDO ! mgs loop for collection efficiencies + +! +! +! +! Set flags for plates vs. columns +! +! + do mgs = 1,ngscnt +! + xplate(mgs) = 0.0 + xcolmn(mgs) = 1.0 +! +! if ( temcg(mgs) .lt. 0. .and. temcg(mgs) .ge. -4. ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -4. .and. temcg(mgs) .ge. -9. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +!c +! if ( temcg(mgs) .lt. -9. .and. temcg(mgs) .ge. -22.5 ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -22.5 .and. temcg(mgs) .ge. -90. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +! + end do +! +! +! +! Collection growth equations.... +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: rain collects xxxxx' +! + do mgs = 1,ngscnt + qracw(mgs) = 0.0 + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. erw(mgs) .gt. 0.0 ) THEN + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 .and. qx(mgs,lr) .gt. 1.e-7 ) THEN + vt = (ar*(xdia(mgs,lc,1)**br))*rhovt(mgs) + qracw(mgs) = & + & (0.25)*pi*erw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lr) & +! > *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *Max(0.0, vtxbar(mgs,lr,1)-vt) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) +! qracw(mgs) = 0.0 +! write(iunit,*) 'qracw,cx =',qracw(mgs),1.e6*xdia(mgs,lr,1),erw(mgs) +! write(iunit,*) 'qracw,cx =',qracw(mgs),cx(mgs,lc),kgs(mgs),cx(mgs,lr),1.e6*xdia(mgs,lr,1),vtxbar(mgs,lr,1),vt +! write(iunit,*) 'vtr: ',vtxbar(mgs,lr,1), ar*gf4br/6.0*xdia(mgs,lr,1)**br, rhovt(mgs), +! : ar*gf4br/6.0*xdia(mgs,lr,1)**br * rhovt(mgs) + ENDIF + ELSE + + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( rwrad .gt. rh(mgs) ) THEN ! .or. cx(mgs,lr) .gt. nh(mgs) ) THEN + IF ( rwrad .gt. rwradmn ) THEN +! DM1CCC=A2*XNC*XNR*XVC*(((CNU+2.)/(CNU+1.))*XVC+XVR) ! (A12) +! NOTE: Result is independent of imurain, assumes mucloud = 3 + qracw(mgs) = erw(mgs)*aa2*cx(mgs,lr)*cx(mgs,lc)*xmas(mgs,lc)* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,lr))/rho0(mgs) !*rhoinv(mgs) + ELSE + + IF ( imurain == 3 ) THEN + +! DM1CCC=A1*XNC*XNR*(((CNU+3.)*(CNU+2.)/(CNU+1.)**2)*XVC**3+ ! (A14) +! 1 ((RNU+2.)/(RNU+1.))*XVC*XVR**2) + +! qracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)* & +! & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**3/(cnu + 1.)**2 + & +! & (alpha(mgs,lr) + 2.)*xv(mgs,lc)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))/rho0(mgs) !*rhoinv(mgs) +! save multiplies by converting cx*xdn*xv/rho0 to qx + qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & + & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + + ELSE ! imurain == 1 + + qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & + & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) + + ENDIF + + ENDIF + ENDIF + ENDIF + ENDIF +! qracw(mgs) = Min(qracw(mgs), qx(mgs,lc)) + qracw(mgs) = Min(qracw(mgs), qcmxd(mgs)) + ENDIF + end do +! + do mgs = 1,ngscnt + qraci(mgs) = 0.0 + craci(mgs) = 0.0 + IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN + IF ( ipconc .ge. 3 ) THEN + + tmp = eri(mgs)*aa2*cx(mgs,lr)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,lr)) + + qraci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) ) + craci(mgs) = Min( cxmxd(mgs,li), tmp ) + +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) +! +! qraci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*qx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab1(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da1(li)*xdia(mgs,li,3)**2 ) +! +! +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) +! +! craci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*cx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab0(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da0(li)*xdia(mgs,li,3)**2 ) +! +! qraci(mgs) = Min( qraci(mgs), qxmxd(mgs,li) ) +! craci(mgs) = Min( craci(mgs), cxmxd(mgs,li) ) + + ELSE + qraci(mgs) = & + & min( & + & (0.25)*pi*eri(mgs)*qx(mgs,li)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qraci(mgs) = 0.0 + end if + ENDIF + end do +! + do mgs = 1,ngscnt + qracs(mgs) = 0.0 + IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + qracs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ers(mgs)*qx(mgs,ls)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lr,1) & + & + gf4*gf3*xdia(mgs,lr,2) ) & + & , qsmxd(mgs)) + ENDIF + end do + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: snow collects xxxxx' +! + do mgs = 1,ngscnt + qsacw(mgs) = 0.0 + csacw(mgs) = 0.0 + vsacw(mgs) = 0.0 + IF ( esw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .ge. 4 ) THEN +! QSACC=CECS*RVT*A2*XNC*XNS*XVC*ROS* +! * (((CNU+2.)/(CNU+1.))*XVC+XVS)/RO + +! tmp = esw(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* +! : ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls)) + tmp = 1.0*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls)) + + qsacw(mgs) = Min( qxmxd(mgs,lc), tmp*xmas(mgs,lc)*rhoinv(mgs) ) + csacw(mgs) = Min( cxmxd(mgs,lc), tmp ) + + IF ( lvol(ls) .gt. 1 ) THEN + IF ( temg(mgs) .lt. 273.15) THEN + rimdn(mgs,ls) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,ls) = Min( Max( rimc3, rimdn(mgs,ls) ), rimc4 ) + ELSE + rimdn(mgs,ls) = 1000. + ENDIF + + vsacw(mgs) = rho0(mgs)*qsacw(mgs)/rimdn(mgs,ls) + + ENDIF + + +! qsacw(mgs) = cecs*aa2*cx(mgs,ls)*cx(mgs,lc)*xmas(mgs,lc)* +! : ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls))*rhoinv(mgs) + ELSE +! qsacw(mgs) = +! > min( +! > ((0.25)*pi)*esw(mgs)*qx(mgs,lc)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,lc,1) +! > + gf1*xdia(mgs,lc,2) ) +! < , qcmxd(mgs)) + + vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) + + qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt* & + & ( da0(ls)*xdia(mgs,ls,3)**2 + & + & dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) + qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) ) + csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc) + ENDIF + ENDIF + end do +! +! + do mgs = 1,ngscnt + qsaci(mgs) = 0.0 + csaci(mgs) = 0.0 + csaci0(mgs) = 0.0 + IF ( ipconc .ge. 4 ) THEN + IF ( esi(mgs) .gt. 0.0 .or. ( ipelec > 0 .and. esiclsn(mgs) > 0.0 )) THEN +! QSCOI=CEXS*RVT*A2*XNCI*XNS*XVCI*ROS* +! * (((CINU+2.)/(CINU+1.))*VCIP+XVS)/RO + + tmp = esiclsn(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,ls)) + + qsaci(mgs) = Min( qxmxd(mgs,li), esi(mgs)*tmp*xmas(mgs,li)*rhoinv(mgs) ) + csaci0(mgs) = tmp + csaci(mgs) = Min(cxmxd(mgs,li), esi(mgs)*tmp ) + +! qsaci(mgs) = +! > min( +! > ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) +! > + gf1*xdia(mgs,li,2) ) +! < , qimxd(mgs)) + ENDIF + ELSE ! + IF ( esi(mgs) .gt. 0.0 ) THEN + qsaci(mgs) = & + & min( & + & ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) & + & *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,ls,2) & + & + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do +! +! +! + do mgs = 1,ngscnt + qsacr(mgs) = 0.0 + qsacrs(mgs) = 0.0 + csacr(mgs) = 0.0 + IF ( esr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN +! vt = Sqrt((vtxbar(mgs,ls,1)-vtxbar(mgs,lr,1))**2 + +! : 0.04*vtxbar(mgs,ls,1)*vtxbar(mgs,lr,1) ) +! qsacr(mgs) = esr(mgs)*cx(mgs,ls)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,ls,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,ls,2)) +! qsacr(mgs) = Min( qsacr(mgs), qrmxd(mgs) ) +! csacr(mgs) = qsacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +! csacr(mgs) = min(csacr(mgs),crmxd(mgs)) + ELSE + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + + qsacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,ls,1) & + & + gf4*gf3*xdia(mgs,ls,2) ) & + & , qrmxd(mgs)) + ENDIF + ENDIF + end do +! +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' +! + do mgs = 1,ngscnt + qhacw(mgs) = 0.0 + rarx(mgs,lh) = 0.0 + vhacw(mgs) = 0.0 + vhsoak(mgs) = 0.0 + zhacw(mgs) = 0.0 + + IF ( .false. ) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lh,1) = Min( vtmax, vtxbar(mgs,lh,1)) + vtxbar(mgs,lh,2) = Min( vtmax, vtxbar(mgs,lh,2)) + vtxbar(mgs,lh,3) = Min( vtmax, vtxbar(mgs,lh,3)) + ENDIF + IF ( ehw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .ge. 2 ) THEN + + IF ( .false. ) THEN + qhacw(mgs) = (ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh)*pi* & + & abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* & + & (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + & + & xdia(mgs,lc,1)*gf73rds) + & + & xdia(mgs,lc,2)*gf83rds))/4. + + ELSE ! using Seifert coefficients + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) + + qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lc,lh)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) + + ENDIF + qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + +!! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +!! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + ENDIF + + ELSE + qhacw(mgs) = & + & min( & + & ((0.25)*pi)*ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) & + & , 0.5*(qx(mgs,lc)-qcwresv(mgs))*dtpinv) +! < , qxmxd(mgs,lc)) +! < , qcmxd(mgs)) + + + IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and. qhacw(mgs) > 0.0) THEN + qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh)) +! qaacw = Min( qaacw, 0.5*(qsacw(mgs) + qhacw(mgs) ) ) + qsacw(mgs) = qaacw + qhacw(mgs) = qaacw + ENDIF + + ENDIF + + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail + + IF ( temg(mgs) .lt. 273.15) THEN + IF ( irimdenopt == 1 ) THEN ! Heymsfield and Pflaum (1985) + vt = ( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) + + rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vt ) & + & /(temg(mgs)-273.15))**(rimc2) +! rimdn(mgs,lh) = Min( Max( hdnmn, rimc3, rimdn(mgs,lh) ), rimc4 ) + rimdn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) + +! IF ( igs(mgs) == 30 ) THEN +! write(0,*) 'k,vt: ',kgs(mgs),vt, vtxbar(mgs,lh,1),vtxbar(mgs,lh,2), rhovt(mgs)*axh(mgs)*( (alpha(mgs,lh)+3.)*xdia(mgs,lh,1) )**bxh(mgs) +! write(0,*) 'diam: char, mean, maxmass = ',xdia(mgs,lh,1),xdia(mgs,lh,3),(alpha(mgs,lh)+3.)*xdia(mgs,lh,1) +! write(0,*) 'ax,bx,cd,xdn = ',axh(mgs),bxh(mgs),cdxgs(mgs,lh),xdn(mgs,lh) +! write(0,*) 'vt_char,vt_mean = ',rhovt(mgs)*axh(mgs)*( xdia(mgs,lh,1) )**bxh(mgs),rhovt(mgs)*axh(mgs)*( xdia(mgs,lh,3) )**bxh(mgs) +! write(0,*) 'rimdn,alpha = ',rimdn(mgs,lh),alpha(mgs,lh) +! ENDIF + + ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993) + + tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & + & /(temg(mgs)-273.15)) + tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) ! have to limit range of "R" because quadratic function starts to decrease (unphysically) at higher values + + rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2) + + ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + + tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & + & /(temg(mgs)-273.15)) + ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + + ENDIF + ELSE + rimdn(mgs,lh) = 1000. + ENDIF + + IF ( lvol(lh) > 1 ) vhacw(mgs) = rho0(mgs)*qhacw(mgs)/rimdn(mgs,lh) + + ENDIF + + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .ge. 1 ) THEN + rarx(mgs,lh) = & + & qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh)) + ENDIF + + ENDIF + end do +! +! + do mgs = 1,ngscnt + qhaci(mgs) = 0.0 + qhaci0(mgs) = 0.0 + IF ( ehi(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + + qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + qhaci(mgs) = Min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) ) + ELSE + qhaci(mgs) = & + & min( & + & ((0.25)*pi)*ehi(mgs)*ehiclsn(mgs)*qx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do + + + IF ( lis > 1 .and. ipconc >= 5 ) THEN + do mgs = 1,ngscnt + qhacis(mgs) = 0.0 + qhacis0(mgs) = 0.0 + IF ( ehis(mgs) .gt. 0.0 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) + + qhacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*qx(mgs,lis)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lis,lh)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & da1(li)*xdia(mgs,lis,3)**2 ) + qhacis(mgs) = Min( ehis(mgs)*qhacis0(mgs), qxmxd(mgs,lis) ) + ENDIF + end do + ENDIF + +! +! + do mgs = 1,ngscnt + qhacs(mgs) = 0.0 + qhacs0(mgs) = 0.0 + IF ( ehs(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + + qhacs(mgs) = Min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) ) + + ELSE + qhacs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehs(mgs)*ehsclsn(mgs)*qx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qsmxd(mgs)) + ENDIF + ENDIF + end do +! + do mgs = 1,ngscnt + qhacr(mgs) = 0.0 + qhacrmlr(mgs) = 0.0 + vhacr(mgs) = 0.0 + chacr(mgs) = 0.0 + zhacr(mgs) = 0.0 + IF ( temg(mgs) .gt. tfr ) raindn(mgs,lh) = 1000.0 + + IF ( ehr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) +! qhacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) + + qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lr,lh)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + qhacr(mgs) = Min( qhacr(mgs), qxmxd(mgs,lr) ) + + qhacrmlr(mgs) = qhacr(mgs) + + IF ( temg(mgs) > tfr .and. iehr0c == 0 ) THEN + qhacr(mgs) = 0.0 + + IF ( iqhacrmlr == 0 ) THEN + qhacrmlr(mgs) = -qhacw(mgs) + ENDIF + + ELSE +! chacr(mgs) = Min( qhacr(mgs)*rho0(mgs)/xmas(mgs,lr), cxmxd(mgs,lr) ) + +! chacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : cx(mgs,lr)*0.25*pi* +! : (0.69874*xdia(mgs,lr,2) + +! : 1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) + +! chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* +! : ( da0lh(mgs)*xdia(mgs,lh,3)**2 + +! : dab0lh(mgs,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + +! : da0(lr)*xdia(mgs,lr,3)**2 ) + +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp + + chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + +! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacr(mgs) ) + ENDIF + ENDIF ! temg > tfr + + ELSE + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,lh,1) + ENDIF + + qhacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehr(mgs)*qx(mgs,lr)*cx(mgs,lh) & + & *abs(vt-vtxbar(mgs,lr,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qrmxd(mgs)) + + IF ( temg(mgs) > tfr ) THEN + IF ( iqhacrmlr >= 1 ) qhacrmlr(mgs) = qhacr(mgs) + qhacr(mgs) = 0.0 + ENDIF + + ENDIF + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail + + IF ( temg(mgs) .lt. 273.15) THEN + raindn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lr,3)) & + & *((0.60)*vt) & + & /(temg(mgs)-273.15))**(rimc2) + + raindn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) + ELSE + raindn(mgs,lh) = 1000. + ENDIF + + IF ( lvol(lh) > 1 ) vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh) + ENDIF + ENDIF + end do + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: hail collects xxxxx' +! + + do mgs = 1,ngscnt + qhlacw(mgs) = 0.0 + vhlacw(mgs) = 0.0 + vhlsoak(mgs) = 0.0 + IF ( lhl > 1 .and. .true.) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lhl,1) = Min( vtmax, vtxbar(mgs,lhl,1)) + vtxbar(mgs,lhl,2) = Min( vtmax, vtxbar(mgs,lhl,2)) + vtxbar(mgs,lhl,3) = Min( vtmax, vtxbar(mgs,lhl,3)) + ENDIF + + IF ( lhl > 0 ) THEN + rarx(mgs,lhl) = 0.0 + ENDIF + + IF ( lhl .gt. 1 .and. ehlw(mgs) .gt. 0.0 ) THEN + + +! IF ( ipconc .ge. 2 ) THEN + + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) + + qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lc,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) + + + qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + IF ( lvol(lhl) .gt. 1 ) THEN + + IF ( temg(mgs) .lt. 273.15) THEN + IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985) + rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,lhl) = Min( Max( hldnmn, rimc3, rimdn(mgs,lhl) ), rimc4 ) + + ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993) + tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & + & /(temg(mgs)-273.15) + tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2) + + ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & + & /(temg(mgs)-273.15) + ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + + ENDIF + ELSE + rimdn(mgs,lhl) = 1000. + ENDIF + + vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/rimdn(mgs,lhl) + + ENDIF + + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .ge. 1 ) THEN + rarx(mgs,lhl) = & + & qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl)) + ENDIF + + ENDIF + end do + + qhlaci(:) = 0.0 + qhlaci0(:) = 0.0 + IF ( lhl .gt. 1 ) THEN + do mgs = 1,ngscnt + IF ( ehli(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) + + qhlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,li,lhl)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + ! qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) ) + qhlaci(mgs) = Min( ehli(mgs)*qhlaci0(mgs), qimxd(mgs) ) + ENDIF + ENDIF + end do + ENDIF +! + qhlacs(:) = 0.0 + qhlacs0(:) = 0.0 + IF ( lhl .gt. 1 ) THEN + do mgs = 1,ngscnt + IF ( ehls(mgs) .gt. 0.0) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + + qhlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,ls,lhl)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + + qhlacs(mgs) = Min( ehls(mgs)*qhlacs0(mgs), qsmxd(mgs) ) + ENDIF + ENDIF + end do + ENDIF + + + do mgs = 1,ngscnt + qhlacr(mgs) = 0.0 + qhlacrmlr(mgs) = 0.0 + chlacr(mgs) = 0.0 + vhlacr(mgs) = 0.0 + IF ( lhl .gt. 1 .and. temg(mgs) .gt. tfr ) raindn(mgs,lhl) = 1000.0 + + IF ( lhl .gt. 1 .and. ehlr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) + + qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lr,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + qhlacr(mgs) = Min( qhlacr(mgs), qxmxd(mgs,lr) ) + + + IF ( iqhlacrmlr >= 1 ) qhlacrmlr(mgs) = qhlacr(mgs) + + IF ( temg(mgs) > tfr .and. iehlr0c == 0) THEN + qhlacr(mgs) = 0.0 + IF ( iqhlacrmlr == 0 ) THEN + qhlacrmlr(mgs) = -qhlacw(mgs) + ENDIF + ELSE + chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da0(lr)*xdia(mgs,lr,3)**2 ) + + chlacr(mgs) = min(chlacr(mgs),crmxd(mgs)) + + IF ( lvol(lhl) .gt. 1 ) THEN + vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/raindn(mgs,lhl) + ENDIF + ENDIF + ENDIF + ENDIF + end do + + + +! +! +! +! +! if (ndebug .gt. 0 ) write(0,*) 'Collection: Cloud collects xxxxx' + + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx2' +! + do mgs = 1,ngscnt + qiacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN + + vt = Sqrt((vtxbar(mgs,li,1)-vtxbar(mgs,lc,1))**2 + & + & 0.04*vtxbar(mgs,li,1)*vtxbar(mgs,lc,1) ) + + qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) + + qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) ) + ENDIF + end do + + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8' +! + do mgs = 1,ngscnt + qiacr(mgs) = 0.0 + qiacrf(mgs) = 0.0 + qiacrs(mgs) = 0.0 + ciacrs(mgs) = 0.0 + ciacr(mgs) = 0.0 + ciacrf(mgs) = 0.0 + viacrf(mgs) = 0.0 + csplinter(mgs) = 0.0 + qsplinter(mgs) = 0.0 + csplinter2(mgs) = 0.0 + qsplinter2(mgs) = 0.0 + IF ( iacr .ge. 1 .and. eri(mgs) .gt. 0.0 & + & .and. temg(mgs) .le. 270.15 ) THEN + IF ( ipconc .ge. 3 ) THEN + ni = 0.0 + IF ( xdia(mgs,li,1) .ge. 10.e-6 ) THEN + ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 ) + ENDIF + IF ( imurain == 1 ) THEN ! gamma of diameter + IF ( iacrsize /= 4 ) THEN + IF ( iacrsize .eq. 1 ) THEN + ratio = 500.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 2 ) THEN + ratio = 300.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 3 ) THEN + ratio = 40.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 5 ) THEN + ratio = 150.e-6/xdia(mgs,lr,1) + ENDIF + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) +! j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha + + nr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr) + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr) + + ELSE ! iacrsize == 4 : use all + nr = cx(mgs,lr) + qr = qx(mgs,lr) + ENDIF + + vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) + + qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1lh(mgs,lr,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) + + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + + + ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab0lh(mgs,lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & + & da0(lr)*xdia(mgs,lr,3)**2 ) + + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) + +! write(iunit,*) 'qiacr: ',cx(mgs,lr),nr,qx(mgs,lr),qr,qiacr(mgs),ciacr(mgs) +! write(iunit,*) 'xdia r li = ',xdia(mgs,lr,3),xdia(mgs,li,3),xdia(mgs,lr,1),xdia(mgs,li,1) +! write(iunit,*) 'i,j,ratio = ',i,j,ciacrratio(i,j),qiacrratio(i,j) +! write(iunit,*) 'ni,ci = ',ni,cx(mgs,li),qx(mgs,li) + + ELSEIF ( imurain == 3 ) THEN ! gamma of volume +! Set nr to the number of drops greater than 40 microns. + arg = 1000.*xdia(mgs,lr,3) +! nr = cx(mgs,lr)*gaml02( arg ) +! IF ( iacr .eq. 1 ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( iacrsize .eq. 1 ) THEN + nr = cx(mgs,lr)*gaml02d500( arg ) ! number greater than 500 microns in diameter + ELSEIF ( iacrsize .eq. 2 .or. iacrsize .eq. 5 ) THEN + nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter + ELSEIF ( iacrsize .eq. 3 ) THEN + nr = cx(mgs,lr)*gaml02( arg ) ! number greater than 40 microns in diameter + ELSEIF ( iacrsize .eq. 4 ) THEN + nr = cx(mgs,lr) ! all raindrops + ENDIF + ELSE + nr = cx(mgs,lr)*gaml02( arg ) + ENDIF +! ELSEIF ( iacr .eq. 2 ) THEN +! nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter +! ENDIF + IF ( ni .gt. 0.0 .and. nr .gt. 0.0 ) THEN + d0 = xdia(mgs,lr,3) + qiacr(mgs) = xdn(mgs,lr)*rhoinv(mgs)* & + & (0.217239*(0.522295*(d0**5) + & + & 49711.81*(d0**6) - & + & 1.673016e7*(d0**7)+ & + & 2.404471e9*(d0**8) - & + & 1.22872e11*(d0**9))*ni*nr) + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + ciacr(mgs) = & + & (0.217239*(0.2301947*(d0**2) + & + & 15823.76*(d0**3) - & + & 4.167685e6*(d0**4) + & + & 4.920215e8*(d0**5) - & + & 2.133344e10*(d0**6))*ni*nr) + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) +! ciacr(mgs) = qiacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + ENDIF + ENDIF + IF ( iacr .eq. 1 .or. iacr .eq. 3 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vr1mm*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 2 ) THEN + ciacrf(mgs) = ciacr(mgs) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 4 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vfrz*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 5 ) THEN + ciacrf(mgs) = ciacr(mgs)*rzxh(mgs) + ENDIF +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*27.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ENDIF + + + ELSE ! single-moment rain + qiacr(mgs) = & + & min( & + & ((0.25/gf4)*pi)*eri(mgs)*cx(mgs,li)*qx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf4*gf3*xdia(mgs,li,2) ) & + & , qrmxd(mgs)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then +! qiacr(mgs) = 0.0 +! ciacr(mgs) = 0.0 +! end if + + IF ( ipconc .ge. 1 ) THEN + IF ( nsplinter .ge. 1000 ) THEN + ! Lawson et al. 2015 JAS + ! ave. diam of freezing drops in microns + IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN + tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) ! avg. diameter of newly frozen drops in microns + csplinter(mgs) = lawson_splinter_fac*tmpdiam**4*ciacr(mgs) + ENDIF + ELSEIF ( nsplinter .ge. 0 ) THEN + csplinter(mgs) = nsplinter*ciacr(mgs) + ELSE + csplinter(mgs) = -nsplinter*ciacrf(mgs) + ENDIF + qsplinter(mgs) = Min(0.1*qiacr(mgs), csplinter(mgs)*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + ENDIF + + frach = 1.0 + IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN + IF ( ciacr(mgs) > qxmin(lh) ) THEN + xvfrz = rho0(mgs)*qiacr(mgs)/(ciacr(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) + + qiacrs(mgs) = (1.-frach)*qiacr(mgs) + ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) + + ENDIF + ENDIF + + qiacrf(mgs) = frach*qiacr(mgs) + ciacrf(mgs) = frach*ciacrf(mgs) + + IF ( lvol(lh) > 1 ) THEN + viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz + ENDIF + + end do +! +! +! +! + +! snow aggregation here + if ( ipconc .ge. 4 ) then ! + do mgs = 1,ngscnt + csacs(mgs) = 0.0 + IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 ) THEN ! .and. xv(mgs,ls) < 0.25*xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN + csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density + csacs(mgs) = min(csacs(mgs),csmxd(mgs)) + ENDIF + end do + end if +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 11' + if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then + do mgs = 1,ngscnt + ciacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN + ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc) + ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) + ENDIF + end do + + end if + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' + if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + cracw(mgs) = 0.0 + cracr(mgs) = 0.0 + ec0(mgs) = 1.e9 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) & + & .and. qracw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 ) THEN + cracw(mgs) = & + & ((0.25)*pi)*erw(mgs)*(cx(mgs,lc) - ccwresv(mgs))*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) & + & + gf3*xdia(mgs,lr,2) ) + ENDIF + ELSE ! IF ( ipconc .ge. 3 .and. + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN !{ + IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) +! IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6 +! DM0CCC=A2*XNC*XNR*(XVC+XVR) ! (A11) +! NOTE: murain drops out, so same result for imurain = 1 and 3 + cracw(mgs) = aa2*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))*(xv(mgs,lc) + xv(mgs,lr)) + ELSE + IF ( imurain == 3 ) THEN +! DM0CCC=A1*XNC*XNR*(((CNU+2.)/(CNU+1.))*XVC**2+((RNU+2.)/(RNU+1.))*XVR**2) ! (A13) + cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + ELSE ! imurain == 1 USE CP00 for rain DSD in diameter + cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) ) + ENDIF ! imurain + ENDIF + ENDIF ! } rh + ENDIF ! } dmrauto + ENDIF ! ipconc + ENDIF ! qc > qcmin & qr > qrmin + +! Rain self collection (cracr) and break-up (factor of ec0) +! +! + ec0(mgs) = 2.e9 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + ec0(mgs) = 0.0 + cracr(mgs) = 0.0 + ELSE + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + IF ( xdia(mgs,lr,3) .lt. 6.1e-4 ) THEN + ec0(mgs) = 1.0 + ELSE + ec0(mgs) = Exp(-50.0*(50.0*(xdia(mgs,lr,3) - 6.0e-4))) + ENDIF + + + IF ( rwrad .ge. 50.e-6 ) THEN + cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr) + ELSE + IF ( imurain == 3 ) THEN + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.) + ELSE ! imurain == 1 + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) + + ENDIF + ENDIF +! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) + ENDIF + ENDIF + ENDIF + +! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) + end do + end if +! +! +! +! Graupel +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + + IF ( ipconc .ge. 5 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN + +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chacw(mgs) = (ehw(mgs)*cx(mgs,lc)*cx(mgs,lh)*(pi/4.)* +! : abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) + +! chacw(mgs) = Min( chacw(mgs), 0.6*cx(mgs,lc)*dtpinv ) + +! chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmascw(mgs) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) + chacw(mgs) = Min( chacw(mgs), 0.5*(cx(mgs,lc) - ccwresv(mgs))*dtpinv ) + ELSE + qhacw(mgs) = 0.0 + ENDIF + ELSE + ! single-moment + chacw(mgs) = & + & ((0.25)*pi)*ehw(mgs)*cx(mgs,lc)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + chacw(mgs) = min(chacw(mgs),0.5*cx(mgs,lc)*dtpinv) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) +! chacw(mgs) = min(chacw(mgs),ccmxd(mgs)) + ENDIF + end do + end if +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chaci(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + + chaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) + + ELSE + chaci0(mgs) = & + & ((0.25)*pi)*ehiclsn(mgs)*cx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf1*xdia(mgs,li,2) & + & + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + ENDIF + + chaci(mgs) = min(ehi(mgs)*chaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if + + + chacis(:) = 0.0 + if ( lis > 1 .and. ipconc .ge. 5 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehis(mgs) .gt. 0.0 .or. ( ehisclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) + + chacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*cx(mgs,lis)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lis,lh)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & da0(lis)*xdia(mgs,lis,3)**2 ) + + + chacis(mgs) = min(ehis(mgs)*chacis0(mgs),cxmxd(mgs,lis)) + ENDIF + end do + end if +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' + chacs(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehs(mgs) .gt. 0 ) THEN + IF ( ipconc .ge. 5 .or. ( ehsclsn(mgs) > 0.0 .and. ipelec > 0 ) ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + chacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) + + ELSE + chacs0(mgs) = & + & ((0.25)*pi)*ehsclsn(mgs)*cx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf3*gf1*xdia(mgs,ls,2) & + & + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf1*gf3*xdia(mgs,lh,2) ) + ENDIF + chacs(mgs) = min(ehs(mgs)*chacs0(mgs),csmxd(mgs)) + ENDIF + end do + end if + + +! +! +! Hail +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chlacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + + IF ( lhl .gt. 1 .and. ipconc .ge. 5 ) THEN + IF ( qhlacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN + +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chlacw(mgs) = (ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)*(pi/4.)* +! : abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lhl,1)*(xdia(mgs,lhl,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) + +! chlacw(mgs) = Min( chlacw(mgs), 0.6*cx(mgs,lc)*dtpinv ) + +! chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmascw(mgs) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) + chlacw(mgs) = Min( chlacw(mgs), 0.5*cx(mgs,lc)*dtpinv ) + ELSE + qhlacw(mgs) = 0.0 + ENDIF +! ELSE +! chlacw(mgs) = +! > ((0.25)*pi)*ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) +! > *( gf1*xdia(mgs,lc,2) +! > + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) +! chlacw(mgs) = min(chlacw(mgs),0.5*cx(mgs,lc)*dtpinv) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) +! chlacw(mgs) = min(chlacw(mgs),ccmxd(mgs)) + ENDIF + end do + end if +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chlaci(:) = 0.0 + chlaci0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehli(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehliclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) + + chlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) + +! ELSE +! chlaci(mgs) = +! > ((0.25)*pi)*ehli(mgs)*cx(mgs,li)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1)) +! > *( gf1*xdia(mgs,li,2) +! > + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) + ENDIF + + chlaci(mgs) = min(ehli(mgs)*chlaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if + + + IF ( lis > 1 .and. ipconc .ge. 5) THEN + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chlacis(:) = 0.0 + chlacis0(:) = 0.0 + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehlis(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlisclsn(mgs) > 0.0) ) ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lis,1) ) + + chlacis0(mgs) = 0.25*pi*ehlisclsn(mgs)*cx(mgs,lhl)*cx(mgs,lis)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,lis)*xdia(mgs,lhl,3)*xdia(mgs,lis,3) + & + & da0(lis)*xdia(mgs,lis,3)**2 ) + + + chlacis(mgs) = min(ehlis(mgs)*chlacis0(mgs),cxmxd(mgs,lis)) + ENDIF + end do + ENDIF + +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj' + chlacs(:) = 0.0 + chlacs0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehls(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlsclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + + chlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) + +! ELSE +! chlacs(mgs) = +! > ((0.25)*pi)*ehls(mgs)*cx(mgs,ls)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1)) +! > *( gf3*gf1*xdia(mgs,ls,2) +! > + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lhl,1) +! > + gf1*gf3*xdia(mgs,lhl,2) ) + ENDIF + chlacs(mgs) = min(ehls(mgs)*chlacs0(mgs),csmxd(mgs)) + ENDIF + end do + end if + +! +! Ziegler (1985) autoconversion +! +! + IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion + if (ndebug .gt. 0 ) write(0,*) 'conc 26a' + + DO mgs = 1,ngscnt + zrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + crcnw(mgs) = 0.0 + cautn(mgs) = 0.0 + ENDDO + + DO mgs = 1,ngscnt +! qracw(mgs) = 0.0 +! cracw(mgs) = 0.0 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN + ! .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing + volb = xv(mgs,lc)*(1./(1.+alpha(mgs,lc)))**(1./2.) + cautn(mgs) = Min(ccmxd(mgs), & + & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) + cautn(mgs) = Max( 0.0d0, cautn(mgs) ) + IF ( rb(mgs) .le. 7.51d-6 ) THEN + t2s = 1.d30 +! cautn(mgs) = 0.0 + ELSE +! XL2P=2.7E-2*XNC*XVC*((1.E12*RB**3*RC)-0.4) + +! T2S=3.72E-3/(((1.E4*RB)-7.5)*XNC*XVC) +! t2s = 3.72E-3/(((1.e6*rb)-7.5)*cx(mgs,lc)*xv(mgs,lc)) +! t2s = 3.72/(((1.e6*rb(mgs))-7.5)*rho0(mgs)*qx(mgs,lc)) + t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc)) + + qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) ) + crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) ) + + IF ( dmrauto == 0 ) THEN + IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19) + crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs) + ELSEIF ( ( dmropt == 1 .or. dmropt == 3 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + crcnw(mgs) = Min(tmp,crcnw(mgs) ) + ELSEIF ( ( dmropt == 4 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr using converted qc mass + crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ELSEIF ( ( dmropt == 5 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr using full qc mass + crcnw(mgs) = (tmp*qx(mgs,lc)+tmp2*qx(mgs,lr))/(qx(mgs,lc)+qx(mgs,lr)) + ELSEIF ( ( dmropt == 6 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass*diameter-weighted average of old and new Dmr (using full qc mass) + crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/(xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) + ELSEIF ( ( dmropt == 7 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try diameter-weighted average of old and new Dmr + crcnw(mgs) = (tmp*xdia(mgs,lc,3)+tmp2*xdia(mgs,lr,3))/(xdia(mgs,lc,3)+xdia(mgs,lr,3)) + ELSEIF ( ( dmropt == 8 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try sqrt(diameter)-weighted average of old and new Dmr + crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/(sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) + ENDIF + ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN + IF ( qx(mgs,lr) > qxmin(lr) ) THEN + tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + crcnw(mgs) = Min(tmp,crcnw(mgs) ) + ENDIF + ELSEIF ( dmrauto == 2 .and. cx(mgs,lr) > cxmin) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr + crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ELSEIF ( dmrauto == 3 .and. cx(mgs,lr) > cxmin) THEN ! adapted from MY/CP code + tmp = Max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) ) + crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3) + ENDIF + + IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 + +! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) +! : THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s,qx(mgs,lr) +! write(0,*) ' ',qx(mgs,lc),cx(mgs,lc),0.5e6*xdia(mgs,lc,1) +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3/(4.*pi))*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.),rh(mgs)*1.e6,rwrad(mgs) +! ELSEIF ( crcnw(mgs) .gt. 1.0 .and. cautn(mgs) .gt. 0.) THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3*pi/4.)*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.) +! ENDIF +! crcnw(mgs) = Min(cautn(mgs),3.5e9*xl2p(mgs)/t2s) + +! IF ( qrcnw(mgs) .gt. 0.3e-2 ) THEN +! write(0,*) 'QRCNW' +! write(0,*) qrcnw(mgs),crcnw(mgs),cautn(mgs) +! write(0,*) xl2p,t2s,rho0(mgs),xv(mgs,lc),cx(mgs,lc),qx(mgs,lc) +! write(0,*) rb,0.5*xdia(mgs,lc,1),mgs,igs(mgs),kgs(mgs) +! ENDIF +! qrcnw(mgs) = Min(qrcnw(mgs),qcmxd(mgs)) + ENDIF + + + ENDIF + ENDDO + + + + ELSE + +! +! Berry 1968 auto conversion for rain (Orville & Kopp 1977) +! +! + if ( ircnw .eq. 4 ) then + do mgs = 1,ngscnt +! sconvmix(lcw,mgs) = 0.0 + qrcnw(mgs) = 0.0 + qdiff = max((qx(mgs,lc)-qminrncw),0.0) + if ( qdiff .gt. 0.0 .and. xdia(mgs,lc,1) .gt. 20.0e-6 ) then + argrcnw = & + & ((1.2e-4)+(1.596e-12)*(cx(mgs,lc)*1.0e-6) & + & /(cwdisp*qdiff*1.0e-3*rho0(mgs))) + qrcnw(mgs) = (rho0(mgs)*1e-3)*(qdiff**2)/argrcnw +! sconvmix(lcw,mgs) = max(sconvmix(lcw,mgs),0.0) + qrcnw(mgs) = (max(qrcnw(mgs),0.0)) + end if + end do + + ENDIF +! +! +! +! Berry 1968 auto conversion for rain (Ferrier 1994) +! +! + if ( ircnw .eq. 5 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + qccrit = (pi/6.)*(cx(mgs,lc)*cwdiap**3)*xdn(mgs,lc)/rho0(mgs) + qdiff = max((qx(mgs,lc)-qccrit),0.) + if ( qdiff .gt. 0.0 .and. cx(mgs,lc) .gt. 1.0 ) then + argrcnw = & +! > ((1.2e-4)+(1.596e-12)*cx(mgs,lc)/(cwdisp*rho0(mgs)*qdiff)) & + & ((1.2e-4)+(1.596e-12)*cx(mgs,lc)*1.0e-3/(cwdisp*rho0(mgs)*qdiff)) + qrcnw(mgs) = & +! > timflg(mgs)*rho0(mgs)*(qdiff**2)/argrcnw & + & 1.0e-3*rho0(mgs)*(qdiff**2)/argrcnw + qrcnw(mgs) = Min(qxmxd(mgs,lc), (max(qrcnw(mgs),0.0)) ) + +! write(iunit,*) 'qrcnw,cx =',qrcnw(mgs),cx(mgs,lc),mgs,1.e3*qx(mgs,lc),cno(lr) + end if + end do + end if + +! +! +! kessler auto conversion for rain. +! + if ( ircnw .eq. 2 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + qrcnw(mgs) = (0.001)*max((qx(mgs,lc)-qminrncw),0.0) + end do + end if +! +! c4 = pi/6 +! c1 = 0.12-0.32 for colorado storms...typically 0.3-0.4 +! berry reinhart type conversion (proctor 1988) +! + if ( ircnw .eq. 1 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + c1 = 0.2 + c4 = pi/(6.0) + bradp = & + & (1.e+06) * ((c1/(0.38))**(1./3.)) * (xdia(mgs,lc,1)*(0.5)) + bl2 = & + & (0.027) * ((100.0)*(bradp**3)*(xdia(mgs,lc,1)*(0.5)) - (0.4)) + bt2 = (bradp -7.5) / (3.72) + qrcnw(mgs) = 0.0 + if ( bl2 .gt. 0.0 .and. bt2 .gt. 0.0 ) then + qrcnw(mgs) = bl2 * bt2 * rho0(mgs) & + & * qx(mgs,lc) * qx(mgs,lc) + end if + end do + end if + + + + ENDIF ! ( ipconc .ge. 2 ) + +! +! +! +! Bigg Freezing of Rain +! + if (ndebug .gt. 0 ) write(0,*) 'conc 27a' + qrfrz(:) = 0.0 + qrfrzs(:) = 0.0 + qrfrzf(:) = 0.0 + vrfrzf(:) = 0.0 + crfrz(:) = 0.0 + crfrzs(:) = 0.0 + crfrzf(:) = 0.0 + zrfrz(:) = 0.0 + zrfrzs(:) = 0.0 + zrfrzf(:) = 0.0 + qwcnr(:) = 0.0 + + IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. .and. ibiggopt > 0 ) then +! brz = 100.0 +! arz = 0.66 + IF ( ipconc .lt. 3 ) THEN + qrfrz(mgs) = & + & min( & + & (20.0)*(pi**2)*brz*(xdn(mgs,lr)/rho0(mgs)) & + & *cx(mgs,lr)*(xdia(mgs,lr,1)**6) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & , qrmxd(mgs)) + qrfrzf(mgs) = qrfrz(mgs) + +! ELSEIF ( ipconc .ge. 3 .and. xv(mgs,lr) .gt. 1.1*xvmn(lr) ) THEN + ELSEIF ( ipconc .ge. 3 ) THEN +! tmp = brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! crfrz(mgs) = xv(mgs,lr)*tmp + + frach = 1.0d0 + +! IF ( ibiggopt == 2 .and. imurain == 1 .and. lzr < 1 ) THEN ! lzr check because results are weird for 3-moment + IF ( ibiggopt == 2 .and. imurain == 1 ) THEN ! + ! integrate from Bigg diameter (for given supercooling Ts) to infinity + + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b, where a = 6.9/6.8, or approx a = 1.0, and b = 16.2 + ! volt is given in cm**3, so convert to m**3 + dbigg = (6./pi* volt )**(1./3.) + + ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. + + ratio = Min(maxratiolu, dbigg/xdia(mgs,lr,1) ) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + IF ( alp0flag ) THEN + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + ELSE + j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + ENDIF + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha; + + crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv + crfrzf(mgs) = crfrz(mgs) + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv + qrfrzf(mgs) = qrfrz(mgs) + + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN + ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) + crfrzf(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + crfrzs(mgs) = crfrz(mgs) + qrfrzs(mgs) = qrfrz(mgs) + + ELSEIF ( dbigg < Max(dfrz,dhmn) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals + ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! + + crfrzs(mgs) = crfrz(mgs) + qrfrzs(mgs) = qrfrz(mgs) + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 1.2*xvmn(lr) ) THEN + ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) + crfrzf(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + + + ELSE !{ + + ! recalculate using dhmn for ratio + ratio = Min( maxratiolu, Max(dfrz,dhmn)/xdia(mgs,lr,1) ) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) +! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) +! j = Int(Max(alphamin,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) + IF ( alp0flag ) THEN + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + ELSE + j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + ENDIF + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + + ! interpolate along alpha; + + crfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv + + ! now subtract off the difference + crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) + qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) + + ENDIF ! } + ELSE + crfrzs(mgs) = 0.0 + qrfrzs(mgs) = 0.0 + ENDIF ! } + + IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN + fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) + qrfrz(mgs) = fac*qrfrz(mgs) + qrfrzs(mgs) = fac*qrfrzs(mgs) + qrfrzf(mgs) = fac*qrfrzf(mgs) + crfrz(mgs) = fac*crfrz(mgs) + crfrzs(mgs) = fac*crfrzs(mgs) + crfrzf(mgs) = fac*crfrzf(mgs) + ENDIF +! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN +! fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr) +! crfrz(mgs) = fac*crfrz(mgs) +! crfrzs(mgs) = fac*crfrzs(mgs) +! ENDIF + +! qrfrzf(mgs) = qrfrz(mgs) +! crfrzf(mgs) = crfrz(mgs) + + ! qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs) + ! crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs) + + + ELSEIF ( ibiggopt == 1 ) THEN + ! Z85, eq. A34 + tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) + IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN ! { +! write(iunit,*) 'Bigg Freezing problem!',mgs,igs(mgs),kgs(mgs) +! write(iunit,*) 'tmp, cx(lr), xv = ',tmp, cx(mgs,lr), xv(mgs,lr), (Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! write(iunit,*) 'qr,temcg = ',qx(mgs,lr)*1000.,temcg(mgs) + crfrz(mgs) = cxmxd(mgs,lr) ! cx(mgs,lr)*dtpinv + qrfrz(mgs) = qxmxd(mgs,lr) ! qx(mgs,lr)*dtpinv +! STOP + ELSE ! } { + crfrz(mgs) = tmp + ! crfrzfmx = cx(mgs,lr)*Exp(-4./3.*pi*(40.e-6)**3/xv(mgs,lr)) + ! IF ( crfrz(mgs) .gt. crfrzmx ) THEN + ! crfrz(mgs) = crfrzmx + ! qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrzmx + ! qwcnr(mgs) = cx(mgs,lr) - crfrzmx + ! ELSE + IF ( lzr < 1 ) THEN + IF ( imurain == 3 ) THEN + bfnu = bfnu0 + ELSE !imurain == 1 + bfnu = bfnu1 + ENDIF + ELSE + ! bfnu = 1.0 ! (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + IF ( imurain == 3 ) THEN + bfnu = (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + ELSE !imurain == 1 +! bfnu = bfnu1 + bfnu = (4. + alpha(mgs,lr))*(5. + alpha(mgs,lr))*(6. + alpha(mgs,lr))/ & + & ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr))) +! bfnu = 1. + ENDIF + ENDIF + qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs) + + qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) + crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)*dtpinv ) !cxmxd(mgs,lr) + qrfrz(mgs) = Min( qrfrz(mgs), qx(mgs,lr) ) + qrfrzf(mgs) = qrfrz(mgs) + ENDIF !} + + + + + IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN !{ Yes, it compares cx and qxmin, but this is just to be sure that + ! crfrz is greater than zero in the division +! IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN +! IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN + + IF ( (ibiggsnow == 1 .or. ibiggsnow == 3 ) .and. ibiggopt /= 2 ) THEN + xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) + + qrfrzs(mgs) = (1.-frach)*qrfrz(mgs) + crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs) +! qrfrzf(mgs) = frach*qrfrz(mgs) + + ENDIF + + IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN + qrfrzs(mgs) = qrfrz(mgs) + crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs) + ELSE +! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)*dtpinv ) ! cxmxd(mgs,lr) +! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) + qrfrzf(mgs) = frach*qrfrz(mgs) +! crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) ) + IF ( ibfr .le. 1 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 5 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) )*rzxh(mgs) !*crfrz(mgs) + ELSEIF ( ibfr .eq. 2 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 6 ) THEN + crfrzf(mgs) = frach*Max(crfrz(mgs), qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSE + crfrzf(mgs) = frach*crfrz(mgs) + ENDIF +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN +! crfrzf(mgs) = crfrz(mgs) +! ENDIF + + ENDIF +! crfrz(mgs) = Min( cxmxd(mgs,lr), rho0(mgs)*qrfrz(mgs)/xmas(mgs,lr) ) + ELSE + crfrz(mgs) = 0.0 + qrfrz(mgs) = 0.0 + ENDIF !} + + ENDIF ! ibiggopt + + IF ( lvol(lh) .gt. 1 ) THEN + vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz + ENDIF + + + IF ( nsplinter .ne. 0 ) THEN + IF ( nsplinter .ge. 1000 ) THEN + ! Lawson et al. 2015 JAS + ! ave. diam of freezing drops in microns + tmp = 0 + IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN + tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.) ! avg. diameter of newly frozen drops in microns + tmp = lawson_splinter_fac*tmpdiam**4*crfrz(mgs) + ENDIF + ELSEIF ( nsplinter .gt. 0 ) THEN + tmp = nsplinter*crfrz(mgs) + ELSE + tmp = -nsplinter*crfrzf(mgs) + ENDIF + csplinter2(mgs) = tmp + qsplinter2(mgs) = Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + +! csplinter(mgs) = csplinter(mgs) + tmp +! qsplinter(mgs) = qsplinter(mgs) + Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + ENDIF +! IF ( temcg(mgs) .lt. -31.0 ) THEN +! qrfrz(mgs) = qx(mgs,lr)*dtpinv + qrcnw(mgs) +! qrfrzf(mgs) = qrfrz(mgs) +! crfrz(mgs) = cx(mgs,lr)*dtpinv + crcnw(mgs) +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! ENDIF +! qrfrz(mgs) = 6.0*xdn(mgs,lr)*xv(mgs,lr)**2*tmp*rhoinv(mgs) +! qrfrz(mgs) = Min( qrfrz(mgs), ffrz*qrmxd(mgs) ) +! crfrz(mgs) = Min( crmxd(mgs), ffrz*crfrz(mgs)) +! crfrz(mgs) = Min(crmxd(mgs),qrfrz(mgs)*rho0(mgs)/xmas(mgs,lr)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then + else +! end if + end if + end do + + ENDIF +! +! Homogeneous freezing of cloud drops to ice crystals +! following Bigg (1953) and Ferrier (1994). +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25b' + do mgs = 1,ngscnt + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + qwfrzc(mgs) = 0.0 + cwfrzc(mgs) = 0.0 + qwfrzp(mgs) = 0.0 + cwfrzp(mgs) = 0.0 + IF ( ibfc .ge. 1 .and. ibfc /= 3 .and. temg(mgs) < 268.15 ) THEN +! if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1. .and. & +! & .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then + if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN + IF ( ipconc < 2 ) THEN + qwfrz(mgs) = ((2.0)*(brz)/(xdn(mgs,lc)*cx(mgs,lc))) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & *rho0(mgs)*(qx(mgs,lc)**2) + qwfrz(mgs) = max(qwfrz(mgs), 0.0) + qwfrz(mgs) = min(qwfrz(mgs),qcmxd(mgs)) + cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li) + ELSEIF ( ipconc .ge. 2 ) THEN + IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 +! dbigg = (6./pi* volt )**(1./3.) + + IF ( alpha(mgs,lc) == 0.0 ) THEN + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))*dtpinv ! number of droplets with volume greater than volt +!turn off limit so that all can freeze at low temp +!!! cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs)) + + qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + ELSE + ratio = (1. + alpha(mgs,lc))*volt/xv(mgs,lc) + + IF ( .false. .and. usegamxinfcnu ) THEN + i = Nint(dgami*(1. + alpha(mgs,lc))) + gcnup1 = gmoi(i) + i = Nint(dgami*(2. + alpha(mgs,lc))) + gcnup2 = gmoi(i) + + cwfrz(mgs) = cx(mgs,lc)*Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1) + + qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) + + ELSE + + ratio = Min( maxratiolu, ratio ) +! write(0,*) 'cwfrz: temp,ratio = ',temcg(mgs),ratio +! write(0,*) 'cwfrz: xv,volt,qx = ',xv(mgs,lc),volt,qx(mgs,lc) +! write(0,*) 'cwfrz: i,j,k = ',igs(mgs),jgs,kgs(mgs) + tmp = gaminterp(ratio,alpha(mgs,lc),1,1) +! write(0,*) 'cwfrz: tmp1 = ',tmp + cwfrz(mgs) = cx(mgs,lc)*tmp*dtpinv ! Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1) + + tmp = gaminterp(ratio,alpha(mgs,lc),12,1) +! write(0,*) 'cwfrz: tmp2 = ',tmp + qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*dtpinv*tmp ! Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) + + ENDIF + + ENDIF + + ENDIF + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + end if + end if + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qwfrzp(mgs) = qwfrz(mgs) + cwfrzp(mgs) = cwfrz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwfrzc(mgs) = qwfrz(mgs) + cwfrzc(mgs) = cwfrz(mgs) + end if + +! +! qwfrzp(mgs) = 0.0 +! qwfrzc(mgs) = qwfrz(mgs) +! + end do +! +! +! Contact freezing nucleation: factor is to convert from L-1 +! T < -2C: via Meyers et al. JAM July, 1992 (31, 708-721) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25a' + do mgs = 1,ngscnt + + ccia(mgs) = 0.0 + + cwctfz(mgs) = 0.0 + qwctfz(mgs) = 0.0 + ctfzbd(mgs) = 0.0 + ctfzth(mgs) = 0.0 + ctfzdi(mgs) = 0.0 + + cwctfzc(mgs) = 0.0 + qwctfzc(mgs) = 0.0 + cwctfzp(mgs) = 0.0 + qwctfzp(mgs) = 0.0 + IF ( icfn .ge. 1 ) THEN + + IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + +! find available # of ice nuclei & limit value to max depletion of cloud water + + IF ( icfn .ge. 2 ) THEN + ccia(mgs) = exp( 4.11 - (0.262)*temcg(mgs) ) ! in m-3, see Walko et al. 1995; 1000*exp(-2.8 -b*t) = exp(6.91)*exp(-2.8 - b*t) = exp(4.11 -b*t) + !ccia(mgs) = Min(cwctfz(mgs), ccmxd(mgs) ) + +! now find how many of these collect cloud water to form IN +! Cotton et al 1986 + + knud(mgs) = 2.28e-5 * temg(mgs) / ( pres(mgs)*raero ) !Walko et al. 1995 + knuda(mgs) = 1.257 + 0.4*exp(-1.1/knud(mgs)) !Pruppacher & Klett 1997 eqn 11-16 + gtp(mgs) = 1. / ( fai(mgs) + fbi(mgs) ) !Byers 65 / Cotton 72b + dfar(mgs) = kb*temg(mgs)*(1.+knuda(mgs)*knud(mgs))/(6.*pi*fadvisc(mgs)*raero) !P&K 1997 eqn 11-15 + fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs) + fn2(mgs) = -gtp(mgs)*(ssw(mgs)-1.)*felv(mgs)/pres(mgs) + fnft(mgs) = 0.4*(1.+1.45*knud(mgs)+0.4*knud(mgs)*exp(-1./knud(mgs)))*(ftka(mgs)+2.5*knud(mgs)*kaero) & + & / ( (1.+3.*knud(mgs))*(2*ftka(mgs)+5.*knud(mgs)*kaero+kaero) ) + + +! Brownian diffusion + ctfzbd(mgs) = fn1(mgs)*dfar(mgs) + +! Thermophoretic contact nucleation + ctfzth(mgs) = fn1(mgs)*fn2(mgs)*fnft(mgs)/rho0(mgs) + +! Diffusiophoretic contact nucleation + ctfzdi(mgs) = fn1(mgs)*fn2(mgs)*rw*temg(mgs)/(felv(mgs)*rho0(mgs)) + + cwctfz(mgs) = max( ctfzbd(mgs) + ctfzth(mgs) + ctfzdi(mgs) , 0.) + +! Sum of the contact nucleation processes +! IF ( cx(mgs,lc) .gt. 1.e6) write(0,*) 'ctfzbd,etc = ',cwctfz(mgs),ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs) +! IF ( wvel(mgs) .lt. -0.05 ) write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs) +! IF ( ssw(mgs) .lt. 1.0 .and. cx(mgs,lc) .gt. 1.e6 .and. cwctfz(mgs) .gt. 1. ) THEN +! write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs),fn1(mgs),fn2(mgs) +! write(6,*) 'more = ',nstep,ssw(mgs),dfar(mgs),gtp(mgs),felv(mgs),pres(mgs) +! ENDIF + + ELSEIF ( icfn .eq. 1 ) THEN + IF ( wvel(mgs) .lt. -0.05 ) THEN ! older kludgy version + cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) ) + cwctfz(mgs) = Min((1.0e3)*cwctfz(mgs), ccmxd(mgs) ) !convert to m-3 + ENDIF + ENDIF ! icfn + + IF ( ipconc .ge. 2 ) THEN + cwctfz(mgs) = Min( cwctfz(mgs)*dtpinv, ccmxd(mgs) ) + qwctfz(mgs) = xmas(mgs,lc)*cwctfz(mgs)/rho0(mgs) + ELSE + qwctfz(mgs) = (cimasn)*cwctfz(mgs)/(dtp*rho0(mgs)) + qwctfz(mgs) = max(qwctfz(mgs), 0.0) + qwctfz(mgs) = min(qwctfz(mgs),qcmxd(mgs)) + ENDIF + +! + if ( xplate(mgs) .eq. 1 ) then + qwctfzp(mgs) = qwctfz(mgs) + cwctfzp(mgs) = cwctfz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwctfzc(mgs) = qwctfz(mgs) + cwctfzc(mgs) = cwctfz(mgs) + end if + +! IF ( cwctfz(mgs)*dtp > 0.5 .and. dtp*qwctfz(mgs) > qxmin(li) ) THEN +! write(91,*) 'cwctfz: ',cwctfz(mgs),qwctfz(mgs) ! ,cwctfzc(mgs),qwctfzc(mgs) +! ENDIF + +! +! qwctfzc(mgs) = qwctfz(mgs) +! qwctfzp(mgs) = 0.0 +! + end if + + ENDIF ! icfn + + end do +! +! +! +! Hobbs-Rangno ice enhancement (Ferrier, 1994) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 23a' + dthr = 300.0 + hrifac = (1.e-3)*((0.044)*(0.01**3)) + do mgs = 1,ngscnt + ciihr(mgs) = 0.0 + qiihr(mgs) = 0.0 + cicichr(mgs) = 0.0 + qicichr(mgs) = 0.0 + cipiphr(mgs) = 0.0 + qipiphr(mgs) = 0.0 + IF ( ihrn .ge. 1 ) THEN + if ( qx(mgs,lc) .gt. qxmin(lc) ) then + if ( temg(mgs) .lt. 273.15 ) then +! write(iunit,'(3(1x,i3),3(1x,1pe12.5))') +! : igs(mgs),jgs,kgs(mgs),cx(mgs,lc),rho0(mgs),qx(mgs,lc) +! write(iunit,'(1pe15.6)') +! : log(cx(mgs,lc)*(1.e-6)/(3.0)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc)), +! : (cx(mgs,lc)*(1.e-6)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)), +! : (alog(cx(mgs,lc)*(1.e-6)/(3.0)) * +! > ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6))) + + IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN + ciihr(mgs) = ((1.69e17)/dthr) & + & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) * & + & ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.) + ciihr(mgs) = ciihr(mgs)*(1.0e6) + qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs) + qiihr(mgs) = max(qiihr(mgs), 0.0) + qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs)) + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qipiphr(mgs) = qiihr(mgs) + cipiphr(mgs) = ciihr(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qicichr(mgs) = qiihr(mgs) + cicichr(mgs) = ciihr(mgs) + end if +! +! qipiphr(mgs) = 0.0 +! qicichr(mgs) = qiihr(mgs) +! + end if + end if + ENDIF ! ihrn + end do +! +! +! +! simple frozen rain to hail conversion. All of the +! frozen rain larger than 5.0e-3 m in diameter are converted +! to hail. This is done by considering the equation for +! frozen rain mixing ratio: +! +! +! qfw = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! /inf +! * | fwdia*3 exp(-dia/fwdia) d(dia) +! /Do +! +! The amount to be reclassified as hail is the integral above from +! Do to inf where Do is 5.0e-3 m. +! +! +! qfauh = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! + + + hdia0 = 300.0e-6 + do mgs = 1,ngscnt + qscnvi(mgs) = 0.0 + cscnvi(mgs) = 0.0 + cscnvis(mgs) = 0.0 +! IF ( .false. ) THEN +! IF ( temg(mgs) .lt. tfr .and. ssi(mgs) .gt. 1.01 .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( temg(mgs) .lt. tfr .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( ipconc .ge. 4 .and. .false. ) THEN + if ( cx(mgs,li) .gt. 10. .and. xdia(mgs,li,1) .gt. 50.e-6 ) then !{ + cirdiatmp = & + & (qx(mgs,li)*rho0(mgs) & + & /(pi*xdn(mgs,li)*cx(mgs,li)))**(1./3.) + IF ( cirdiatmp .gt. 100.e-6 ) THEN !{ + qscnvi(mgs) = & + & ((pi*xdn(mgs,li)*cx(mgs,li)) / (6.0*rho0(mgs)*dtp)) & + & *exp(-hdia0/cirdiatmp) & + & *( (hdia0**3) + 3.0*(hdia0**2)*cirdiatmp & + & + 6.0*(hdia0)*(cirdiatmp**2) + 6.0*(cirdiatmp**3) ) + qscnvi(mgs) = & + & min(qscnvi(mgs),qimxd(mgs)) + IF ( ipconc .ge. 4 ) THEN + cscnvi(mgs) = Min( cimxd(mgs), cx(mgs,li)*Exp(-hdia0/cirdiatmp)) + ENDIF + ENDIF ! } + end if ! } + + ELSEIF ( ipconc .lt. 4 ) THEN + + qscnvi(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscnvi(mgs) = min(qscnvi(mgs),qxmxd(mgs,li)) + cscnvi(mgs) = qscnvi(mgs)*rho0(mgs)/xmas(mgs,li) + cscnvis(mgs) = 0.5*cscnvi(mgs) + + ENDIF + ENDIF +! ENDIF + end do + + + +! +! Ventilation coeficients +! + do mgs = 1,ngscnt + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + end do +! +! + if ( ndebug .gt. 0 ) write(0,*) 'civent' +! + civenta = 1.258e4 + civentb = 2.331 + civentc = 5.662e4 + civentd = 2.373 + civente = 0.8241 + civentf = -0.042 + civentg = 1.70 + + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + cireyn = & + & (civenta*xdia(mgs,li,1)**civentb & + & +civentc*xdia(mgs,li,1)**civentd) & + & / & + & (civente*xdia(mgs,li,1)**civentf+civentg) + xcivent = (fschm(mgs)**(1./3.))*((cireyn/fakvisc(mgs))**0.5) + if ( xcivent .lt. 1.0 ) then + civent(mgs) = 1.0 + 0.14*xcivent**2 + end if + if ( xcivent .ge. 1.0 ) then + civent(mgs) = 0.86 + 0.28*xcivent + end if + ELSE + civent(mgs) = 0.0 + ENDIF + + + ENDIF ! icond .eq. 1 + end do + +! +! + igmrwa = 100.0*2.0 + igmrwb = 100.*((5.0+br)/2.0) + rwventa = (0.78)*gmoi(igmrwa) ! 0.78 + rwventb = (0.308)*gmoi(igmrwb) ! 0.562825 + do mgs = 1,ngscnt + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + + ELSE ! imurain == 1 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lr) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( iferwisventr == 1 ) THEN + + ! Ferrier fall speed in the ventillation term [uses fx(lr) ] + + alpr = Min(alpharmax,alpha(mgs,lr) ) + + x = 1. + alpha(mgs,lr) + + IF ( lzr > 1 ) THEN ! 3 moment +! + ELSE + y = ventrxn(mgs) + ENDIF + +! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK +! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK + vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula -- should be equivalent) + vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) + + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + + + ENDIF ! iferwisventr + + ENDIF ! imurain + ELSE + rwvent(mgs) = & + & (rwventa + rwventb*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + ELSE + rwvent(mgs) = 0.0 + ENDIF + end do +! + igmswa = 100.0*2.0 + igmswb = 100.*((5.0+ds)/2.0) + swventa = (0.78)*gmoi(igmswa) + swventb = (0.308)*gmoi(igmswb) + do mgs = 1,ngscnt + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + swvent(mgs) = 0.65 + 0.44*fvent(mgs)*Sqrt(vtxbar(mgs,ls,1)*xdia(mgs,ls,1)) + ELSE +! 10-ice version: + swvent(mgs) = & + & (swventa + swventb*fvent(mgs) & + & *Sqrt((cs*rhovt(mgs))) & + & *(xdia(mgs,ls,1)**((1.0+ds)/2.0)) ) + ENDIF + ELSE + swvent(mgs) = 0.0 + ENDIF + end do +! +! + + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) +! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25) + IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN + hwvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lh)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lh,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lh) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! note that hwvent includes a division by Gamma(1+alpha), so Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y + x = 1. + alpha(mgs,lh) + + tmp = 1 + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lh) + 0.5*bxh(mgs) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp + + + hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxh(mgs)))*Sqrt(axh(mgs)*rhovt(mgs)) + hwvent(mgs) = & + & ( 0.78*x + y*hwventy(mgs) ) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxh(mgs)))* & +! & Sqrt(axh(mgs)*rhovt(mgs)) ) + + ENDIF + ELSE + hwvent(mgs) = 0.0 + hwventy(mgs) = 0.0 + ENDIF + end do + + hlvent(:) = 0.0 + hlventy(:) = 0.0 + + IF ( lhl .gt. 1 ) THEN + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) +! hwventc = (4.0*gr/(3.0*cdx(lhl)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25) + + IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN + hlvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lhl)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lhl,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lhl) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! note that hlvent includes a division by Gamma(1+alpha), so x = Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y + + x = 1. + alpha(mgs,lhl) + + tmp = 1 + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxhl(mgs) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + + hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxhl(mgs)))*Sqrt(axhl(mgs)*rhovt(mgs)) + + hlvent(mgs) = 0.78*x + y*hlventy(mgs) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxhl(mgs)))* & +! & Sqrt(axhl(mgs)*rhovt(mgs))) +! : Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp + + ENDIF + ENDIF + end do + ENDIF + +! +! +! +! Wet growth constants +! + do mgs = 1,ngscnt + fwet1(mgs) = & + & (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs) ) & + & / ( rho0(mgs)*(felf(mgs)+fcw(mgs)*temcg(mgs)) ) + fwet2(mgs) = & + & (1.0)-fci(mgs)*temcg(mgs) & + & / ( felf(mgs)+fcw(mgs)*temcg(mgs) ) + end do +! +! Melting constants +! + do mgs = 1,ngscnt + fmlt1(mgs) = (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) & + & / (felf(mgs)) + fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) + end do +! +! Vapor Deposition constants +! + do mgs = 1,ngscnt + fvds(mgs) = & + & (4.0*pi/rho0(mgs))*(ssi(mgs)-1.0)* & + & (1.0/(fai(mgs)+fbi(mgs))) + end do + do mgs = 1,ngscnt + fvce(mgs) = & + & (4.0*pi/rho0(mgs))*(ssw(mgs)-1.0)* & + & (1.0/(fav(mgs)+fbv(mgs))) + end do + +! +! deposition, sublimation, and melting of snow, graupel and hail +! + qsmlr(:) = 0.0 + qimlr(:) = 0.0 ! this is not used. qi melts to qc way down in the code. + qhmlr(:) = 0.0 + qhlmlr(:) = 0.0 + IF ( lhwlg > 1 ) THEN + qhmlrlg(:) = 0.0 + qhlmlrlg(:) = 0.0 + ENDIF + qhfzh(:) = 0.0 + qhlfzhl(:) = 0.0 + qhfzhlg(:) = 0.0 + qhlfzhllg(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + qsfzs(:) = 0.0 + zsmlr(:) = 0.0 + zhmlr(:) = 0.0 + zhmlrr(:) = 0.0 + zhshr(:) = 0.0 + zhlmlr(:) = 0.0 + zhlshr(:) = 0.0 + + zhshrr(:) = 0.0 + zhlmlrr(:) = 0.0 + zhlshrr(:) = 0.0 + + csmlr(:) = 0.0 + csmlrr(:) = 0.0 + chmlr(:) = 0.0 + chmlrr(:) = 0.0 + chlmlr(:) = 0.0 +! chlmlrsave(:) = 0.0 +! qhlmlrsave(:) = 0.0 +! chlsave(:) = 0.0 +! qhlsave(:) = 0.0 + chlmlrr(:) = 0.0 + + if ( .not. mixedphase ) then !{ + do mgs = 1,ngscnt +! + IF ( temg(mgs) .gt. tfr ) THEN + + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + qsmlr(mgs) = & + & min( & + & (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & ! /rhosm & + & , 0.0 ) + ENDIF + +! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs), +! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv) +! ELSE +! qsmlr(mgs) = 0.0 +! ENDIF +! 10ice version: +! > min( +! > (fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) + +! > fmlt2(mgs)*(qsacr(mgs)+qsacw(mgs)) ) +! < , 0.0 ) + + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + qhmlr(mgs) = & + & meltfac*min( & + & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & + & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) & + & , 0.0 ) + ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + + write(0,*) 'ibinhmlr = 1 not available for 2-moment' + STOP + + ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN + + ENDIF + + + IF ( ivhmltsoak > 0 .and. qhmlr(mgs) < 0.0 .and. lvol(lh) > 1 .and. xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! act as if 100% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*(vx(mgs,lh) + rho0(mgs)*qhmlr(mgs)/xdn(mgs,lh) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhmlr(mgs)/xdnmx(lh) ! volume of melted ice if it were refrozen in the matrix + + vhsoak(mgs) = Min(v1,v2) + + ENDIF + + ENDIF ! qx(mgs,lh) .gt. qxmin(lh) + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( ibinhlmlr == 0 .or. lzhl < 1) THEN + qhlmlr(mgs) = & + & meltfac*min( & + & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & + & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) & + & , 0.0 ) + + ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + +! #ifdef Z3MOM +! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP ) + + ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results + + ENDIF ! ibinhlmlr + + + IF ( ivhmltsoak > 0 .and. qhlmlr(mgs) < 0.0 .and. lvol(lhl) > 1 .and. xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! act as if 50% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*(vx(mgs,lhl) + rho0(mgs)*qhlmlr(mgs)/xdn(mgs,lhl) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhlmlr(mgs)/xdnmx(lhl) ! volume of melted ice if it were refrozen in the matrix + + vhlsoak(mgs) = Min(v1,v2) + + ENDIF + + ENDIF + ENDIF + + ENDIF + +! +! qimlr(mgs) = max( qimlr(mgs), -qimxd(mgs) ) +! qsmlr(mgs) = max( qsmlr(mgs), -qsmxd(mgs) ) +! erm 5/10/2007 changed to next line: + if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)*dtpinv ) ) + IF ( .not. mixedphase ) THEN + qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.95*qx(mgs,lh)*dtpinv ) ) + chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) + ENDIF +! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion + qhmlh(mgs) = 0. + + + ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN + qhlmlr(mgs) = max( qhlmlr(mgs), Min( -qxmxd(mgs,lhl), -0.95*qx(mgs,lhl)*dtpinv ) ) + chlmlr(mgs) = max( chlmlr(mgs), Min( -cxmxd(mgs,lhl), -0.95*cx(mgs,lhl)*dtpinv ) ) + ENDIF + +! + end do + + endif ! } not mixedphase +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs) + IF ( .not. mixedphase ) THEN !{ + IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN +! csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm) + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ELSEIF ( qx(mgs,ls) > qxmin(ls) ) THEN + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ENDIF + + csmlrr(mgs) = csmlr(mgs)/rzxs(mgs) + IF ( -csmlrr(mgs)*dtp > cxmin .and. -qsmlr(mgs)*dtp > qxmin(lr) .and. snowmeltdia > 0.0 ) THEN + rmas = rho0(mgs)*qsmlr(mgs)/csmlrr(mgs) + IF ( rmas > snowmeltmass ) THEN + csmlrr(mgs) = rho0(mgs)*qsmlr(mgs)/snowmeltmass + ENDIF + ENDIF + + + +! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN +! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail +! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) ) +! ELSE + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) + IF ( imltshddmr == 3 .and. qhmlr(mgs) < -qxmin(lh) ) THEN + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! + ! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam + ! chmlr(mgs) = 0.0 + ! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller + + tmp = 1. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lh,1) ) + + x = gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxh(mgs), ratio)/g1palp + + hwvent1 = 0.78*x + y*hwventy(mgs) + + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lh)*hwvent1*xdia(mgs,lh,1), 0.0 ) + + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*(qhmlr(mgs) - qhlmlr1) + + + ENDIF +! IF ( igs(mgs) == 40 ) THEN +! write(0,*) 'is this running? chmlr = ',kgs(mgs), chmlr(mgs) +! ENDIF + ENDIF +! ENDIF + + + + IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0 + + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + IF ( ihmlt .eq. 1 ) THEN + chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN +! chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain +! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas + IF(imltshddmr == 1) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop + tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + + chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) ! old version + chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + ELSE ! Old method + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! into rain + ENDIF + ELSE + chmlrr(mgs) = chmlr(mgs) + ENDIF + ELSEIF ( ihmlt .eq. 0 ) THEN + chmlrr(mgs) = chmlr(mgs) + ENDIF + + ELSE ! ibinhmlr < 0? Already have an outer IF test for ibinhmlr < 1 + chmlrr(mgs) = Min( chmlrr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF + + ENDIF ! } ( chmlr(mgs) < 0.0 .and. ibinhmlr < 1) + + IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN ! { + + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN +! IF ( xdia(mgs,lhl,1) .gt. 1.e-6 .and. Abs(qhlmlr(mgs)) .ge. qxmin(lhl) ) THEN +! chlmlr(mgs) = rho0(mgs)*qhlmlr(mgs)/(pi*xdn(mgs,lhl)*xdia(mgs,lhl,1)**3) ! out of hail +! chlmlr(mgs) = Max( chlmlr(mgs), -cxmxd(mgs,lhl) ) +! ELSE + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlmlr(mgs) + IF ( imltshddmr == 3 .and. qhlmlr(mgs) < -qxmin(lhl) ) THEN +! IF ( .false. .and. imltshddmr == 3 ) THEN +! tmpdiam = (shedalp+alpha(mgs,lhl))*xdia(mgs,lhl,1) +! +! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam +! chlmlr(mgs) = 0.0 +! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller +! + tmp = 1. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lhl,1) ) + + x = gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxhl(mgs), ratio)/g1palp + + hwvent1 = 0.78*x + y*hlventy(mgs) + + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lhl)*hwvent1*xdia(mgs,lhl,1), 0.0 ) + + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*Min(0.0, qhlmlr(mgs) - qhlmlr1) + + ENDIF +! ENDIF + ENDIF + + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN !{ + IF ( ihmlt .eq. 1 ) THEN + chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain +! chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain + IF(imltshddmr == 1 ) THEN + tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam) + chlmlrr(mgs) = -Max(tmp,Min(tmp2,chlmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + ELSE ! old method + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + ENDIF + ELSE + chlmlrr(mgs) = chlmlr(mgs) + ENDIF + ELSEIF ( ihmlt .eq. 0 ) THEN + chlmlrr(mgs) = chlmlr(mgs) + ENDIF + + ELSE ! } { ibinhlmlr > 0 + chlmlrr(mgs) = Min( chlmlrr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF !} + + + ENDIF ! } + + ENDIF ! }.not. mixedphase + +! 10ice versions: +! chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) +! chmlrr(mgs) = chmlr(mgs) + end do + end if + +! +! deposition/sublimation of ice +! + DO mgs = 1,ngscnt + + rwcap(mgs) = (0.5)*xdia(mgs,lr,1) + swcap(mgs) = (0.5)*xdia(mgs,ls,1) + hwcap(mgs) = (0.5)*xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1) + + if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then +! +! from Cotton, 1972 (Part II) +! + cilen(mgs) = 0.4764*(xdia(mgs,li,1))**(0.958) + cval = xdia(mgs,li,1) + aval = cilen(mgs) + eval = Sqrt(1.0-(aval**2)/(cval**2)) + fval = min(0.99,eval) + gval = alog( abs( (1.+fval)/(1.-fval) ) ) + cicap(mgs) = cval*fval / gval + ELSE + cicap(mgs) = 0.0 + end if + ENDDO +! +! + qhldsv(:) = 0.0 + + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + qidsv(mgs) = & + & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac + qsdsv(mgs) = & + & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1), +! : fvds(mgs),civent(mgs),cicap(mgs) +! ENDIF + ELSE + qidsv(mgs) = 0.0 + qsdsv(mgs) = 0.0 + ENDIF + qhdsv(mgs) = & + & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs)*depfac + + IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs)*depfac +! +! + end do +! + + +! #include "nssl.qlimit.F" + +! +! Use a test saturation adjustment to set limits on ice deposition/sublimation +! and rain evaporation +! +! + IF ( DoSublimationFix ) THEN + + do mgs = 1,ngscnt + + qitmp(mgs) = qx(mgs,li) + qx(mgs,ls) + qx(mgs,lh) + IF ( lis > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lis) + IF ( lhl > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lhl) + qrtmp(mgs) = qx(mgs,lr) + qctmp(mgs) = qx(mgs,lc) + qsimxdep(mgs) = 0.0 + qsimxsub(mgs) = 0.0 + dqcitmp(mgs) = 0.0 + + +! IF ( ( qitmp(mgs) > qxmin(li) .or. qrtmp(mgs) > qxmin(lr) ) ) THEN + IF ( qitmp(mgs) > qxmin(li) ) THEN + + qitmp1 = qitmp(mgs) + qctmp1 = qctmp(mgs) + felvcptmp = felvcp(mgs) + felscptmp = felscp(mgs) + qvtmp(mgs) = qx(mgs,lv) + qss(mgs) = qvs(mgs) + qsstmp = qvs(mgs) + qvstmp = qvs(mgs) + qisstmp = qis(mgs) + thetatmp = theta(mgs) + thetaptmp = thetap(mgs) + temgtmp = temg(mgs) + temcgtmp = temcg(mgs) + qvaptmp = qx(mgs,lv) ! qwvp(mgs) + qv0(mgs) + qvptmp = 0.0 ! qwvp(mgs) ! qv pertubation + + qsstmp = qisstmp + + + dqwvtmp(mgs) = ( qvtmp(mgs) - qsstmp ) + + do itertd = 1,2 + +! +! calculate super-saturation +! + IF ( itertd == 1 ) THEN + + ELSE + dqcitmp(mgs) = dqci(mgs) + ! dqwvtmp(mgs) = dqwv(mgs) + ENDIF + + dqcw(mgs) = 0.0 + dqci(mgs) = 0.0 + dqwv(mgs) = ( qvtmp(mgs) - qsstmp ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! { subsaturated + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit + dqci(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all ice available for sublimation + dqci(mgs) = -qitmp(mgs) + dqwv(mgs) = dqwv(mgs) + qitmp(mgs) + end if +! + qvptmp = qvptmp - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor + + IF ( itertd == 2 .and. eqtset > 1 ) THEN + ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content + tmp = qitmp(mgs) !+ qx(mgs,lh) +! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qvtmp(mgs)+cpl*(qx(mgs,lc)+qrtmp(mgs)) & + +cpigb*(tmp) + + felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm + felscptmp = (fels(mgs)-rw*temg(mgs))/cvm + ENDIF + + +! qitmp(mgs) = qx(mgs,li) + qctmp(mgs) = qctmp(mgs) + dqcw(mgs) ! dqcw is zero + qitmp(mgs) = qitmp(mgs) + dqci(mgs) + thetaptmp = thetaptmp + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + + + end if ! } dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN ! { + +! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) +! +! qitmp(mgs) = qx(mgs,li) + fracl(mgs) = 0.0 + fraci(mgs) = 1.0 + if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then +! fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) +! fraci(mgs) = 1.0-fracl(mgs) + end if + if ( temg(mgs) .le. thnuc ) then + fraci(mgs) = 1.0 + fracl(mgs) = 0.0 + end if +! fraci(mgs) = 1.0-fracl(mgs) + + gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & + & / (pi0(mgs)) + + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qsstmp/ & + & ((temg(mgs)-cbi)**2)) + + if ( temg(mgs) .ge. tfr ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qsstmp/ & + & ((temg(mgs)-cbw)**2)) + end if + + delqci1=qx(mgs,li) + + + dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) ! is zero + dqci(mgs) = dqvcnd(mgs)*fraci(mgs) + + thetaptmp = thetaptmp + & + & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & + & / (pi0(mgs)) + + qvptmp = qvptmp - ( dqvcnd(mgs) ) + qctmp(mgs) = qctmp(mgs) + dqcw(mgs) + qitmp(mgs) = qitmp(mgs) + dqci(mgs) + + IF ( itertd == 2 .and. eqtset > 1 ) THEN + ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content + tmp = qitmp(mgs) ! + qx(mgs,lh) +! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qvtmp(mgs)+cpl*(qctmp(mgs) +qrtmp(mgs)) & + +cpigb*(tmp) + + felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm + felscptmp = (fels(mgs)-rw*temg(mgs))/cvm + ENDIF + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (0 & + & +felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + +! +! + END IF ! } dqwv(mgs) .ge. 0. + + +! + IF ( itertd == 1 ) THEN + ! update temporary saturation values + + thetatmp = thetaptmp + theta0(mgs) + temgtmp = thetatmp*pk(mgs) ! ( pres(mgs) / poo ) ** cap + qvaptmp = Max((qvptmp + qv0(mgs)), 0.0) + temcgtmp = temgtmp - tfr + tqvcon = temgtmp-cbw + ltemq = (temgtmp-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvstmp = pqs(mgs)*tabqvs(ltemq) + qisstmp = pqs(mgs)*tabqis(ltemq) + qctmp(mgs) = max( 0.0, qctmp(mgs) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + qvtmp(mgs) = max( 0.0, qvaptmp ) + +! qsstmp = qvstmp + qsstmp = qisstmp + + ELSE + ! set max depletion + qctmp(mgs) = max( 0.0, qctmp(mgs) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + + IF ( qitmp(mgs) < qitmp1 ) THEN + qsimxsub(mgs) = (qitmp1 - qitmp(mgs))*dtpinv + ELSEIF ( qitmp(mgs) > qitmp1 ) THEN + qsimxdep(mgs) = (qitmp(mgs) - qitmp1)*dtpinv + ENDIF + + + ENDIF +! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv +! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qxtmp,qctmp(mgs) +! +! end the saturation adjustment iteration loop +! + end do ! itertd + + ENDIF + + end do ! mgs + + ELSE + + DO mgs = 1,ngscnt + qsimxdep(mgs) = qvimxd(mgs) + qsimxsub(mgs) = 1.e20 + ENDDO + + ENDIF + +! end of qlimit + + do mgs = 1,ngscnt + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN +! qisbv(mgs) = max( min(qidsv(mgs), 0.0), -qimxd(mgs) ) +! qssbv(mgs) = max( min(qsdsv(mgs), 0.0), -qsmxd(mgs) ) +! erm 5/10/2007: + qisbv(mgs) = max( min(qidsv(mgs), 0.0), Min( -qimxd(mgs), -0.5*qx(mgs,li)*dtpinv ) ) + qssbv(mgs) = max( min(qsdsv(mgs), 0.0), Min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) ) + qidpv(mgs) = Max(qidsv(mgs), 0.0) + qsdpv(mgs) = Max(qsdsv(mgs), 0.0) + + + ELSE + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 + ENDIF + + qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) + + + qhdpv(mgs) = Max(qhdsv(mgs), 0.0) + + qhlsbv(mgs) = 0.0 + qhldpv(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) + qhldpv(mgs) = Max(qhldsv(mgs), 0.0) + ENDIF + + temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) + +! IF ( temp1 .gt. qvimxd(mgs) ) THEN + +! frac = qvimxd(mgs)/temp1 + + IF ( temp1 .gt. qsimxdep(mgs) ) THEN + frac = qsimxdep(mgs)/temp1 + + qidpv(mgs) = frac*qidpv(mgs) + qsdpv(mgs) = frac*qsdpv(mgs) + qhdpv(mgs) = frac*qhdpv(mgs) + qhldpv(mgs) = frac*qhldpv(mgs) + +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac +! ENDIF + + ENDIF + + temp1 = qisbv(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) + + + IF ( temp1 < -qsimxsub(mgs) ) THEN + frac = -qsimxsub(mgs)/temp1 + + qisbv(mgs) = frac*qisbv(mgs) + qssbv(mgs) = frac*qssbv(mgs) + qhsbv(mgs) = frac*qhsbv(mgs) + qhlsbv(mgs) = frac*qhlsbv(mgs) + +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac +! ENDIF + + ENDIF + + + end do +! +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cssbv(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qssbv(mgs) + cisbv(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qisbv(mgs) + chsbv(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhsbv(mgs) + IF ( lhl .gt. 1 ) chlsbv(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlsbv(mgs) + csdpv(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsdpv(mgs) + cidpv(mgs) = 0.0 ! (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qidpv(mgs) + cisdpv(mgs) = 0.0 + chdpv(mgs) = 0.0 ! (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhdpv(mgs) + chldpv(mgs) = 0.0 + end do + end if + +! +! Aggregation or size conversion of small crystals to snow +! + if (ndebug .gt. 0 ) write(0,*) 'conc 29a' + do mgs = 1,ngscnt + qscni(mgs) = 0.0 + cscni(mgs) = 0.0 + cscnis(mgs) = 0.0 + if ( ipconc .ge. 4 .and. iscni .ge. 1 .and. qx(mgs,li) .gt. qxmin(li) ) then + IF ( iscni .eq. 1 ) THEN + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + cscnis(mgs) = 0.5*cscni(mgs) + ELSEIF ( iscni .eq. 2 .or. iscni .eq. 4 .or. iscni .eq. 5 ) THEN ! Zeigler 1985/Zrnic 1993, sort of + IF ( iscni .ne. 5 .and. qidpv(mgs) .gt. 0.0 .and. xdia(mgs,li,3) .ge. 100.e-6 ) THEN + ! convert larger crystals to snow +! IF ( xdia(mgs,ls,3) .gt. xdia(mgs,li,3) ) THEN +! qscni(mgs) = Max(0.1,xdia(mgs,li,3)/xdia(mgs,ls,3))*qidpv(mgs) +! erm 9/5/08 changed max to min + qscni(mgs) = Min(0.5, xdia(mgs,li,3)/200.e-6)*qidpv(mgs) +! ELSE +! qscni(mgs) = 0.1*qidpv(mgs) +! ENDIF + cscni(mgs) = fscni*qscni(mgs)*rho0(mgs)/Max(rho_qs*xvmn(ls),xmas(mgs,li)) +! cscni(mgs) = fscni*Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvmn(ls),xmas(mgs,li))) +! cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li) ) +! IF ( xdia(mgs,ls,3) .le. 200.e-6 ) THEN + cscnis(mgs) = cscni(mgs) +! ELSE +! cscnis(mgs) = 0.0 +! ENDIF + ENDIF + + IF ( iscni .ne. 4 ) THEN + ! crystal aggregation to become snow +! erm 9/5/08 commented second line and added xv to 1st line (zrnic et al 1993) + tmp = ess(mgs)*rvt*aa2*cx(mgs,li)*cx(mgs,li)*xv(mgs,li) +! : ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,li)) + +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) + + qscni(mgs) = qscni(mgs) + Min( qxmxd(mgs,li), 2.0*tmp*xmas(mgs,li)*rhoinv(mgs) ) + cscni(mgs) = cscni(mgs) + Min( cxmxd(mgs,li), 2.0*tmp ) + cscnis(mgs) = cscnis(mgs) + Min( cxmxd(mgs,li), tmp ) + ENDIF + ELSEIF ( iscni .eq. 3 ) THEN ! LFO + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + cscni(mgs) = qscni(mgs)*rho0(mgs)/xmas(mgs,li) + cscnis(mgs) = 0.5*cscni(mgs) +! write(iunit,*) 'qscni, qi = ',qscni(mgs),qx(mgs,li),igs(mgs),kgs(mgs) + ENDIF + + ELSEIF ( ipconc < 4 ) THEN ! LFO + IF ( lwsm6 ) THEN + qimax = rhoinv(mgs)*roqimax + qscni(mgs) = Min(0.90*qx(mgs,li), Max( 0.0, (qx(mgs,li) - qimax)*dtpinv ) ) + ELSE + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + ENDIF + else ! 10-ice version + if ( iscni > 0 .and. qx(mgs,li) .gt. qxmin(li) ) then + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + end if + + end if + end do + +! +! +! compute dry growth rate of snow, graupel, and hail +! + do mgs = 1,ngscnt +! + qsdry(mgs) = qsacr(mgs) + qsacw(mgs) & + & + qsaci(mgs) +! + qhdry(mgs) = qhaci(mgs) + qhacs(mgs) & + & + qhacr(mgs) & + & + qhacw(mgs) +! + qhldry(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & + & + qhlacr(mgs) & + & + qhlacw(mgs) + ENDIF + end do +! +! set wet growth and shedding +! + do mgs = 1,ngscnt + + IF ( temg(mgs) < tfr ) THEN +! +! qswet(mgs) = +! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) +! > + fwet2(mgs)*(qsaci(mgs)+qsacir(mgs) +! > +qsacip(mgs)) ) +! qswet(mgs) = max( 0.0, qswet(mgs)) +! +! IF ( dnu(lh) .ne. 0. ) THEN +! qhwet(mgs) = qhdry(mgs) +! ELSE + qhwet(mgs) = & + & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & + & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) + qhwet(mgs) = max( 0.0, qhwet(mgs)) +! ENDIF + + qhlwet(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlwet(mgs) = & + & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) + qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + ENDIF + + ELSE + + qhwet(mgs) = qhdry(mgs) + qhlwet(mgs) = qhldry(mgs) + + ENDIF +! +! qhlwet(mgs) = qhldry(mgs) + + end do +! +! shedding rate +! + qsshr(:) = 0.0 + qhshr(:) = 0.0 + qhlshr(:) = 0.0 + qhshh(:) = 0.0 + csshr(:) = 0.0 + csshrr(:) = 0.0 + chshr(:) = 0.0 + chlshr(:) = 0.0 + chshrr(:) = 0.0 + chlshrr(:) = 0.0 + vhshdr(:) = 0.0 + vhlshdr(:) = 0.0 + wetsfc(:) = .false. + wetgrowth(:) = .false. + wetsfchl(:) = .false. + wetgrowthhl(:) = .false. + + + do mgs = 1,ngscnt +! +! +! + qhshr(mgs) = Min( 0.0, qhwet(mgs) - qhdry(mgs) ) ! water that freezes should never be more than what sheds + + + + qhlshr(mgs) = Min( 0.0, qhlwet(mgs) - qhldry(mgs) ) + +! +! limit wet growth to only higher density particles +! + qsshr(mgs) = 0.0 +! +! +! no shedding for temperatures < 243.15 +! + if ( temg(mgs) .lt. 243.15 ) then + qsshr(mgs) = 0.0 + qhshr(mgs) = 0.0 + qhlshr(mgs) = 0.0 + vhshdr(mgs) = 0.0 + vhlshdr(mgs) = 0.0 + wetsfc(mgs) = .false. + wetgrowth(mgs) = .false. + wetsfchl(mgs) = .false. + wetgrowthhl(mgs) = .false. + end if +! +! shed all at temperatures > 273.15 +! + if ( temg(mgs) .gt. tfr ) then + + IF ( .false. ) THEN ! old and incorrect -- Thanks to Shaofeng Hua for noticing this error (9/17/2017) + qsshr(mgs) = -qsdry(mgs) + qhshr(mgs) = -qhdry(mgs) + qhlshr(mgs) = -qhldry(mgs) + + ELSE ! new and correct + + qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) + qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs) + qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs) + + ENDIF + + vhshdr(mgs) = -vhacw(mgs) - vhacr(mgs) + vhlshdr(mgs) = -vhlacw(mgs) - vhlacr(mgs) + qhwet(mgs) = 0.0 + qhlwet(mgs) = 0.0 + end if +! +! if (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) + wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) +! ENDIF + + if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) + wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) + ENDIF + + end do +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) + ! why is there a number loss for graupel for shedding? NEED TO CHECK THIS + ! chshr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) + ! IF ( temg(mgs) < tfr ) chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding + + chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + + IF ( .false. ) THEN + IF ( temg(mgs) < tfr ) THEN + chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding + ELSE + IF(imltshddmr > 0) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop + tmp = -Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain + tmp2 = -rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) + chshrr(mgs) = -Max(tmp,Min(tmp2,chshrr(mgs))) + ELSE + chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to maximum size allowed for rain or 4.5mm diameter, whichever is smaller +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + ENDIF + ENDIF + ENDIF + + + chlshr(mgs) = 0.0 + chlshrr(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN +! chlshr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) + + + chlshr(mgs) = 0.0 ! no change to hail number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + + + IF ( .false. ) THEN + IF ( temg(mgs) < tfr ) THEN + chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding +! chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vr1mm) ) ! maximum of 1mm drops from shedding + ELSE + IF(imltshddmr > 0) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop + tmp = -Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain + tmp2 = -rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chlshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lhl,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(sheddiam0-sheddiam) + chlshrr(mgs) = -Max(tmp,Min(tmp2,chlshrr(mgs))) + ELSE + chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to 4.5mm diameter or maximum size allowed for rain, whichever is smaller +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + ENDIF + ENDIF + ENDIF + + ENDIF ! ( lhl > 1 ) + + end do + end if + + + +! +! final decisions +! + do mgs = 1,ngscnt +! +! Snow +! + if ( qsshr(mgs) .lt. 0.0 ) then + qsdpv(mgs) = 0.0 + qssbv(mgs) = 0.0 + else + qsshr(mgs) = 0.0 + end if +! +! if ( qsdry(mgs) .lt. qswet(mgs) ) then +! qswet(mgs) = 0.0 +! else +! qsdry(mgs) = 0.0 +! end if +! + +! graupel +! +! + if ( wetgrowth(mgs) .or. (mixedphase .and. fhw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then + + +! soaking (when not advected liquid water film with graupel) + + IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN + ! rescale volumes to maximum density + rimdn(mgs,lh) = xdnmx(lh) + raindn(mgs,lh) = xdnmx(lh) + vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh) + vhacr(mgs) = qhacr(mgs)*rho0(mgs)/raindn(mgs,lh) +! IF ( lvol(lh) .gt. 1 .and. wetgrowth(mgs) ) THEN + IF ( xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! soak some liquid into the graupel +! v1 = xdnmx(lh)*vx(mgs,lh)/(xdn(mgs,lh)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*vx(mgs,lh)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lh)/rho0(mgs))*(xdnmx(lh) - xdn(mgs,lh)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion + + vhsoak(mgs) = Min(v1,v2) + + ENDIF + + vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) + + ELSEIF ( lvol(lh) .gt. 1 .and. mixedphase ) THEN +! vhacw(mgs) = rho0(mgs)*qhacw(mgs)/xdn0(lr) +! vhacr(mgs) = rho0(mgs)*qhacr(mgs)/xdn0(lr) + ENDIF + + + qhdpv(mgs) = 0.0 +! qhsbv(mgs) = 0.0 + chdpv(mgs) = 0.0 +! chsbv(mgs) = 0.0 + +! collection efficiency modification + + IF ( ehi(mgs) .gt. 0.0 ) THEN + qhaci(mgs) = Min(qimxd(mgs),qhaci0(mgs)) ! effectively sets collection eff to 1 + chaci(mgs) = Min(cimxd(mgs),chaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF + IF ( ehs(mgs) .gt. 0.0 ) THEN +! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs)) ! effectively sets collection eff to 1 + qhacs(mgs) = Min(qsmxd(mgs),qhacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + chacs(mgs) = Min(csmxd(mgs),chacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it + qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)) ! plug it back in + ENDIF + +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfc(mgs) = .true. + + else +! qhshr(mgs) = 0.0 + end if +! +! +! hail +! +! if ( lhl .gt. 1 .and. qhlshr(mgs) .lt. 0.0 ) then + if ( lhl > 1 .and. ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) ) then +! if ( wetgrowthhl(mgs) ) then + + + qhldpv(mgs) = 0.0 +! qhlsbv(mgs) = 0.0 + chldpv(mgs) = 0.0 +! chlsbv(mgs) = 0.0 + + + + + IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN +! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN + + rimdn(mgs,lhl) = xdnmx(lhl) + raindn(mgs,lhl) = xdnmx(lhl) + vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) + vhlacr(mgs) = qhlacr(mgs)*rho0(mgs)/raindn(mgs,lhl) + + IF ( xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! soak some liquid into the hail +! v1 = xdnmx(lhl)*vx(mgs,lhl)/(xdn(mgs,lhl)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*vx(mgs,lhl)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lhl)/rho0(mgs))*(xdnmx(lhl) - xdn(mgs,lhl)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) ! volume of frozen accretion + IF ( v1 > v2 ) THEN ! all the frozen stuff fits in + vhlsoak(mgs) = v2 + ELSE ! fill up the available space + vhlsoak(mgs) = v1 + ENDIF +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = Max( 0.0, v2 - v1 ) + ELSE + vhlsoak(mgs) = 0.0 +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl) + + ENDIF + + vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) + + + ELSEIF ( lvol(lhl) .gt. 1 .and. mixedphase ) THEN +! vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/xdn0(lr) +! vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/xdn0(lr) + ENDIF + + IF ( ehli(mgs) .gt. 0.0 ) THEN + qhlaci(mgs) = Min(qimxd(mgs),qhlaci0(mgs)) ! effectively sets collection eff to 1 + chlaci(mgs) = Min(cimxd(mgs),chlaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF + +! IF ( ehls(mgs) .gt. 0.0 ) THEN +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs)) +! ENDIF + IF ( ehls(mgs) .gt. 0.0 ) THEN + qhlacs(mgs) = Min(qsmxd(mgs),qhlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + chlacs(mgs) = Min(csmxd(mgs),chlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + ehls(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)) ! plug it back in + ENDIF + + +! qhlwet(mgs) = 1.0 + +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfchl(mgs) = .true. + + + else +! qhlshr(mgs) = 0.0 +! qhlwet(mgs) = 0.0 + end if + + + end do +! +! Ice -> graupel conversion +! + DO mgs = 1,ngscnt + + qhcni(mgs) = 0.0 + chcni(mgs) = 0.0 + chcnih(mgs) = 0.0 + vhcni(mgs) = 0.0 + + IF ( iglcnvi .ge. 1 ) THEN + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs) - qidpv(mgs) .gt. 0.0 ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + + IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = (qiacw(mgs) - qidpv(mgs)) ! *float(iglcnvi) + chcni(mgs) = cx(mgs,li)*qhcni(mgs)/qx(mgs,li) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + + ELSEIF ( iglcnvi == 3 ) THEN + + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs)*dtp > 2.*qxmin(lh) .and. gamice73fac*xmas(mgs,li) > xdnmn(lh)*xvmn(lh) ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp .ge. xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = 0.5*qiacw(mgs) + chcni(mgs) = qhcni(mgs)/(gamice73fac*xmas(mgs,li)) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + + ENDIF + + + ENDIF + ENDIF + + + ENDDO + + + qhlcnh(:) = 0.0 + chlcnh(:) = 0.0 + chlcnhhl(:) = 0.0 + vhlcnh(:) = 0.0 + vhlcnhl(:) = 0.0 + zhlcnh(:) = 0.0 + + qhcnhl(:) = 0.0 + chcnhl(:) = 0.0 + vhcnhl(:) = 0.0 + zhcnhl(:) = 0.0 + + + IF ( lhl .gt. 1 ) THEN + + IF ( ihlcnh == 1 .or. ihlcnh == 3 ) THEN + +! +! Graupel (h) conversion to hail (hl) based on Milbrandt and Yau 2005b +! + DO mgs = 1,ngscnt + +! IF ( lhl .gt. 1 .and. ipconc .ge. 5 .and. qx(mgs,lh) .gt. 1.0e-3 .and. +! : xdn(mgs,lh) .gt. 750. .and. qhshr(mgs) .lt. 0.0 .and. +! : xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( hlcnhdia > 0 ) THEN + ltest = xdia(mgs,lh,3) .gt. hlcnhdia ! test on mean volume diameter + ELSE +! ltest = xdia(mgs,lh,1)*(3. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on maximum mass diameter + ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter + ENDIF + + dg0(mgs) = -1. + + wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) + + IF ( ihlcnh == 1 ) THEN ! .or. iusedw == 0 THEN + + IF ( ( wetgrowth(mgs) .and. (xdn(mgs,lh) .gt. hldnmn .or. lvh < 1 ) .and. & ! correct this when hail gets turned on + & rimdn(mgs,lh) .gt. 800. .and. & + & ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN ! { +! : xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3 THEN ! 0823.2008 erm test +! IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN ! { + ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05 +! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - +! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0) + IF ( wtest ) THEN + dh0 = dg0(mgs) + ELSE + x = (1.1e4*(rho0(mgs)*qx(mgs,lc)) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0e-3 ) + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dh0 = 0.01*(exp(arg) - 1.0) + ELSE + dh0 = 1.e30 + ENDIF + ENDIF ! wtest +! dh0 = Max( dh0, 5.e-3 ) + +! IF ( dh0 .gt. 0.0 ) write(0,*) 'dh0 = ',dh0 +! IF ( dh0 .gt. 1.0e-4 ) THEN + IF ( xdia(mgs,lh,3)/dh0 .gt. 0.1 ) THEN !{ +! IF ( xdia(mgs,lh,3) .lt. 20.*dh0 .and. dh0 .lt. 2.0*xdia(mgs,lh,3) ) THEN + tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) +! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) + qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) +! IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN +! hdia1 = Max(dh0, xdia(mgs,lh,3) ) +! qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, & +! & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & +! & *exp(-hdia1/xdia(mgs,lh,1)) & +! & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) & +! & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) ) + +! ENDIF + +! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) +! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) + qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) + + IF ( ipconc .ge. 5 ) THEN !{ +! dh0 = Max( xdia(mgs,lh,3), Min( dh0, 5.e-3 ) ) ! do not create hail greater than 5mm diam. unless the graupel is larger + IF ( .not. wtest ) dh0 = Min( dh0, 10.e-3 ) ! do not create hail greater than 10mm diam., which is the max graupel size + IF ( qx(mgs,lhl) > 0.1e-3 ) dh0 = Max( dh0, xdia(mgs,lhl,3) ) ! when enough hail is established, do not dilute the size + chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) ) + + r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter +! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r ) +! chlcnh(mgs) = Min( chlcnh(mgs), r ) + chlcnh(mgs) = Max( chlcnhhl(mgs), r ) + ENDIF !} + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF !} + + ENDIF ! } + ENDIF ! } + + ELSEIF ( ihlcnh == 3 ) THEN !{ + + IF ( wtest .and. & + ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) ) THEN + ! convert number, mass, and reflectivity for d > dw + ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) + + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + + IF ( qxd1 > qxmin(lhl) ) THEN + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + cxd1 = cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN + dh0 = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs) + IF ( dh0 < xmas(mgs,lhl) ) THEN + ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average + dh0 = (( qxd1*dh0**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average + chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 ) + ELSE +! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size + ENDIF + ENDIF + + + + ELSE + qhlcnh(mgs) = 0.0 + ENDIF + +! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN +! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! ENDIF + +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 +! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 +! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 +! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDIF !} + + ENDDO + + ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion + +! +! Staka and Mansell (2005) type conversion -- assuming alphah = 0 for now! +! +! hldia1 is set in micro_module and namelist + IF ( .true. ) THEN + + ! convert number, mass, and reflectivity for d > hldia1, + ! regardless of wet growth status, but as long as riming > 0 + DO mgs = 1,ngscnt + IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN + ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + cxd1 = cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + +! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN +! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! ENDIF + +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 +! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 +! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 +! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDDO + + ELSEIF ( ihlcnh == 0 ) THEN + + do mgs = 1,ngscnt +! qhlcnh(mgs) = 0.0 +! chlcnh(mgs) = 0.0 + if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then + if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then + qhlcnh(mgs) = & + ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & + *exp(-hldia1/xdia(mgs,lh,1)) & + *( (hldia1**3) + 3.0*(hldia1**2)*xdia(mgs,lh,1) & + + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) + qhlcnh(mgs) = min(qhlcnh(mgs),qhmxd(mgs)) + IF ( ipconc .ge. 5 ) THEN + chlcnh(mgs) = Min( cxmxd(mgs,lh), cx(mgs,lh)*Exp(-hldia1/xdia(mgs,lh,1))) + chlcnhhl(mgs) = chlcnh(mgs) +! chlcnh(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(2.0*xmas(mgs,lh) )) + ENDIF + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + end if + end if + end do + + ENDIF ! true + + ENDIF ! ihlcnh options + + ! convert low-density hail to graupel + IF ( icvhl2h >= 1 ) THEN + DO mgs = 1,ngscnt + IF ( qx(mgs,lhl) > qxmin(lhl) .and. xdn(mgs,lhl) < 0.5*(xdnmn(lhl) + xdnmx(lhl)) ) THEN + tmp = Min(0.95, 1. - 0.5*(1. + tanh(0.125*(xdn(mgs,lhl) - 1.01*xdnmn(lhl) )) )) + qhcnhl(mgs) = tmp*qx(mgs,lhl)*dtpinv + chcnhl(mgs) = cx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) + vhcnhl(mgs) = vx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) + + ENDIF + ENDDO + + ENDIF + + + ENDIF ! lhl > 1 + + +! +! Ziegler snow conversion to graupel +! + DO mgs = 1,ngscnt + + qhcns(mgs) = 0.0 + chcns(mgs) = 0.0 + chcnsh(mgs) = 0.0 + vhcns(mgs) = 0.0 + + qscnh(mgs) = 0.0 + cscnh(mgs) = 0.0 + vscnh(mgs) = 0.0 + + IF ( ipconc .ge. 5 ) THEN + + ! test attempt at converting graupel to snow when not riming but growing by deposition + IF ( temg(mgs) < tfr .and. qx(mgs,lh) .gt. qxmin(lh) .and. qhdpv(mgs) > qxmin(lh)*dtpinv & + & .and. qhacw(mgs) < qxmin(lh)*dtpinv ) THEN + IF ( xdn(mgs,lh) < 290. ) THEN +! qscnh(mgs) = 2.*qhdpv(mgs) +! cscnh(mgs) = cx(mgs,lh)*qscnh(mgs)/qx(mgs,lh) +! vscnh(mgs) = rho0(mgs)*qscnh(mgs)/xdn(mgs,lh) + ENDIF + ENDIF + + + IF ( qx(mgs,ls) .gt. qxmin(ls) .and. qsacw(mgs) .gt. 0.0 ) THEN + +! DATA VGRA/1.413E-2/ ! this is the volume (cm**3) of a 3mm diam. sphere +! vgra = 1.4137e-8 m**3 + +! DNNET=DNCNV-DNAGG +! DQNET=QXCON+QSACC+SDEP +! +! DNSCNV=EXP(-(ROS*XNS*VGRA/(RO*QI)))*((1.-(XNS*VGRA*ROS/ +! / (RO*QI)))*DNNET + (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET) +! IF(DNSCNV.LT.0.) DNSCNV=0. +! +! QIHC=(ROS*VGRA/RO)*DNSCNV +! +! QH=QH+DT*QIHC +! QI=QI-DT*QIHC +! XNH=XNH+DT*DNSCNV +! XNS=XNS-DT*DNSCNV + + IF ( iglcnvs .eq. 1 ) THEN ! Zrnic, Ziegler et al (1993) + + dnnet = cscnvis(mgs) + cscnis(mgs) - csacs(mgs) + dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs) + + a3 = 1./(rho0(mgs)*qx(mgs,ls)) + a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) !! EXP(-(ROS*XNS*VGRA/(RO*QI))) +! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET + a2 = (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet +! (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET + a4 = cx(mgs,ls)**2*vgra*xdn(mgs,ls)*a3/qx(mgs,ls)*dqnet + + chcns(mgs) = Max( 0.0, a1*(a2 + a4) ) + chcns(mgs) = Min( chcns(mgs), cxmxd(mgs,ls) ) + chcnsh(mgs) = chcns(mgs) + + qhcns(mgs) = Min( xdn(mgs,ls)*vgra*rhoinv(mgs)*chcns(mgs), qxmxd(mgs,ls) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),xdnmn(lh)) +! vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + + ELSEIF ( iglcnvs .ge. 2 ) THEN ! treat like ice crystals, i.e., check for rime density (ERM) + + IF ( temg(mgs) .lt. 273.0 .and. ( qsacw(mgs) - qsdpv(mgs) .gt. 0.0 .or. & + ( iglcnvs >= 3 .and. qsacw(mgs)*dtp > 2.*qxmin(lh) .and. gamsnow73fac*xmas(mgs,ls) > xdnmn(lh)*xvmn(lh) ) ) ) THEN !{ + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) +! tmp = Min( Max( rimc3, tmp ), 900.0 ) + tmp = Min( tmp , 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + + IF ( iglcnvs == 2 ) THEN !{ + IF ( tmp .ge. 200.0 ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = (qsacw(mgs) - qsdpv(mgs)) + chcns(mgs) = cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF + + ELSEIF ( iglcnvs == 3 ) THEN + + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp > xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = 0.5*qsacw(mgs) + chcns(mgs) = qhcns(mgs)/(gamsnow73fac*xmas(mgs,ls)) + chcns(mgs) = Min( chcns(mgs), cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls)) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF + + ENDIF !} + + ENDIF !} + + ENDIF + + + ENDIF + + ELSE ! single moment lfo + + qhcns(mgs) = 0.001*ehscnv(mgs)*max((qx(mgs,ls)-6.e-4),0.0) + qhcns(mgs) = min(qhcns(mgs),qxmxd(mgs,ls)) + IF ( lvol(lh) .ge. 1 ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + + ENDIF + ENDDO +! +! +! heat budget for rain---not all rain that collects ice can freeze +! +! +! + if ( irwfrz .gt. 0 .and. .not. mixedphase) then +! + do mgs = 1,ngscnt +! +! compute total rain that freeze when it interacts with cloud ice +! + qrztot(mgs) = qrfrz(mgs) + qiacr(mgs) + qsacr(mgs) +! +! compute the maximum amount of rain that can freeze +! Used to limit freezing to 4*qrmxd, but now allow all rain to freeze if possible +! + qrzmax(mgs) = & + & ( xdia(mgs,lr,1)*rwvent(mgs)*cx(mgs,lr)*fwet1(mgs) ) + qrzmax(mgs) = max(qrzmax(mgs), 0.0) + qrzmax(mgs) = min(qrztot(mgs), qrzmax(mgs)) + qrzmax(mgs) = min(qx(mgs,lr)*dtpinv, qrzmax(mgs)) + + IF ( temcg(mgs) < -30. ) THEN ! allow all to freeze if T < -30 because fwet becomes invalid (negative) + qrzmax(mgs) = qx(mgs,lr)*dtpinv + ENDIF +! qrzmax(mgs) = min(4.*qrmxd(mgs), qrzmax(mgs)) +! +! compute the correction factor +! +! IF ( qrztot(mgs) .gt. qxmin(lr) ) THEN + IF ( qrztot(mgs) .gt. qrzmax(mgs) .and. qrztot(mgs) .gt. qxmin(lr) ) THEN + qrzfac(mgs) = qrzmax(mgs)/(qrztot(mgs)) + ELSE + qrzfac(mgs) = 1.0 + ENDIF + qrzfac(mgs) = min(1.0, qrzfac(mgs)) +! + end do +! +! +! now correct the above sources +! +! + do mgs = 1,ngscnt + if ( temg(mgs) .le. 273.15 .and. qrzfac(mgs) .lt. 1.0 ) then + qrfrz(mgs) = qrzfac(mgs)*qrfrz(mgs) + qrfrzs(mgs) = qrzfac(mgs)*qrfrzs(mgs) + qrfrzf(mgs) = qrzfac(mgs)*qrfrzf(mgs) + qiacr(mgs) = qrzfac(mgs)*qiacr(mgs) + qsacr(mgs) = qrzfac(mgs)*qsacr(mgs) + qiacrf(mgs) = qrzfac(mgs)*qiacrf(mgs) + qiacrs(mgs) = qrzfac(mgs)*qiacrs(mgs) + crfrz(mgs) = qrzfac(mgs)*crfrz(mgs) + crfrzf(mgs) = qrzfac(mgs)*crfrzf(mgs) + crfrzs(mgs) = qrzfac(mgs)*crfrzs(mgs) + ciacr(mgs) = qrzfac(mgs)*ciacr(mgs) + ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) + ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) + + + vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) + viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) + end if + end do +! +! +! + end if +! +! +! +! evaporation of rain +! +! +! + qrcev(:) = 0.0 + crcev(:) = 0.0 + + + do mgs = 1,ngscnt +! + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + qrcev(mgs) = & + & fvce(mgs)*cx(mgs,lr)*rwvent(mgs)*rwcap(mgs)*evapfac +! this line to allow condensation on rain: + IF ( rcond .eq. 1 ) THEN + qrcev(mgs) = min(qrcev(mgs), qxmxd(mgs,lv)) +! this line to have evaporation only: + ELSE + qrcev(mgs) = min(qrcev(mgs), 0.0) + ENDIF + + qrcev(mgs) = max(qrcev(mgs), -qrmxd(mgs)) +! if ( temg(mgs) .lt. 273.15 ) qrcev(mgs) = 0.0 + IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN +! qrcev(mgs) = -qrmxd(mgs) +! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs) + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + ELSE + crcev(mgs) = 0.0 + ENDIF +! if ( temg(mgs) .lt. 273.15 ) crcev(mgs) = 0.0 +! + ENDIF + + end do +! +! evaporation/condensation of wet graupel and snow +! + qscev(:) = 0.0 + cscev(:) = 0.0 + qhcev(:) = 0.0 + chcev(:) = 0.0 + qhlcev(:) = 0.0 + chlcev(:) = 0.0 + + IF ( lhwlg > 1 ) THEN + qhcevlg(:) = 0.0 + chcevlg(:) = 0.0 + ENDIF + IF ( lhlwlg > 1 ) THEN + qhlcevlg(:) = 0.0 + chlcevlg(:) = 0.0 + ENDIF + +! +! +! +! ICE MULTIPLICATION: Two modes (rimpa, and rimpb) +! (following Cotton et al. 1986) +! + + chmul1(:) = 0.0 + chlmul1(:) = 0.0 + csmul1(:) = 0.0 +! + qhmul1(:) = 0.0 + qhlmul1(:) = 0.0 + qsmul1(:) = 0.0 + + do mgs = 1,ngscnt + + ltest = qx(mgs,lh) .gt. qxmin(lh) + IF ( lhl > 1 ) ltest = ltest .or. qx(mgs,lhl) .gt. qxmin(lhl) + + IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 ) & + & .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then + IF ( ipconc .ge. 2 ) THEN + IF ( xv(mgs,lc) .gt. 0.0 & + & .and. ltest & +! .and. itype2 .ge. 2 & + & ) THEN +! +! Ziegler et al. 1986 Hallett-Mossop process. VSTAR = 7.23e-15 (vol of 12micron radius) +! + IF ( alpha(mgs,lc) == 0.0 ) THEN + ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc)) + ELSE + + ratio = (1. + alpha(mgs,lc))*(7.23e-15)/xv(mgs,lc) + + IF ( usegamxinfcnu ) THEN + i = Nint(dgami*(1. + alpha(mgs,lc))) + gcnup1 = gmoi(i) + ex1 = (1./250.)*Gamxinf(1.+alpha(mgs,lc), ratio)/(gcnup1) + ELSE + ratio = Min( maxratiolu, ratio ) + tmp = gaminterp(ratio,alpha(mgs,lc),1,1) + ex1 = (1./250.)*tmp + ENDIF + ENDIF + IF ( itype2 .le. 2 ) THEN + ft = Max(0.0,Min(1.0,-0.11*temcg(mgs)**2 - 1.1*temcg(mgs)-1.7)) + ELSE + IF ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) THEN + ft = 0.5 + ELSEIF (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) THEN + ft = 1.0 + ELSEIF (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) THEN + ft = 0.5 + ELSE + ft = 0.0 + ENDIF + ENDIF +! rhoinv = 1./rho0(mgs) +! DNSTAR = ex1*cglacw(mgs) + + IF ( ft > 0.0 ) THEN + + IF ( itype2 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + chmul1(mgs) = ft*ex1*chacw(mgs) +! chmul1(mgs) = Min( ft*ex1*chacw(mgs), ft*(30.*1.e+06)*rho0(mgs)*qhacw(mgs) ) ! 1.e+6 converts kg to mg; Saunders & Hosseini (2001) average of about 30 crystals per mg + qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs) + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + chlmul1(mgs) = (ft*ex1*chlacw(mgs)) + qhlmul1(mgs) = cimas0*chlmul1(mgs)*rhoinv(mgs) + ENDIF + ENDIF + ENDIF ! itype2 + + IF ( itype1 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhacw(mgs) + chmul1(mgs) = chmul1(mgs) + tmp + qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs) + chlmul1(mgs) = chlmul1(mgs) + tmp + qhlmul1(mgs) = qhlmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF + ENDIF + ENDIF ! itype1 + + + ENDIF ! ft + + ENDIF ! xv(mgs,lc) .gt. 0.0 .and. + + ELSE ! ipconc .lt. 2 +! +! define the temperature function +! + fimt1(mgs) = 0.0 +! +! Cotton et al. (1986) version +! + if ( temg(mgs) .ge. 268.15 .and. temg(mgs) .le. 270.15 ) then + fimt1(mgs) = 1.0 -(temg(mgs)-268.15)/2.0 + elseif (temg(mgs) .le. 268.15 .and. temg(mgs) .ge. 265.15 ) then + fimt1(mgs) = 1.0 +(temg(mgs)-268.15)/3.0 + ELSE + fimt1(mgs) = 0.0 + end if +! +! Ferrier (1994) version +! + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) then + fimt1(mgs) = 0.5 + elseif (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) then + fimt1(mgs) = 1.0 + elseif (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) then + fimt1(mgs) = 0.5 + ELSE + fimt1(mgs) = 0.0 + end if +! +! +! type I: 350 splinters are formed for every 1e-3 grams of cloud +! water accreted by graupel/hail (note converted to MKS units) +! 3.5e+8 has units of 1/kg +! + IF ( itype1 .ge. 1 ) THEN + fimta(mgs) = (3.5e+08)*rho0(mgs) + ELSE + fimta(mgs) = 0.0 + ENDIF + +! +! +! type II: 1 splinter formed for every 250 cloud droplets larger than +! 24 micons in diameter (12 microns in radius) accreted by +! graupel/hail +! +! + fimt2(mgs) = 0.0 + xcwmas = xmas(mgs,lc) * 1000. +! + IF ( itype2 .ge. 1 ) THEN + if ( xcwmas.lt.1.26e-9 ) then + fimt2(mgs) = 0.0 + end if + if ( xcwmas .le. 3.55e-9 .and. xcwmas .ge. 1.26e-9 ) then + fimt2(mgs) = (2.27)*alog(xcwmas) + 13.39 + end if + if ( xcwmas .gt. 3.55e-9 ) then + fimt2(mgs) = 1.0 + end if + + fimt2(mgs) = min(fimt2(mgs),1.0) + fimt2(mgs) = max(fimt2(mgs),0.0) + + ENDIF +! +! qhmul2 = 0.0 +! qsmul2 = 0.0 +! +! qhmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qhacw(mgs) +! qsmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qsacw(mgs) +! +! cimas0 = (1.0e-12) +! cimas0 = 2.5e-10 + IF ( .not. wetsfc(mgs) ) THEN + chmul1(mgs) = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhacw(mgs) + ENDIF +! + qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) + + + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhlacw(mgs) + chlmul1(mgs) = tmp + qhlmul1(mgs) = cimas0*tmp*rhoinv(mgs) + ENDIF + ENDIF + +! qsmul1(mgs) = csmul1(mgs)*(cimas0/rho0(mgs)) +! + ENDIF ! ( ipconc .ge. 2 ) + + end if ! (in temperature range) + + ENDIF ! ( itype1 .eq. 1 .or. itype2 .eq. 1) +! + end do +! +! +! +! end if +! +! end do +! +! +! ICE MULTIPLICATION FROM SNOW +! Lo and Passarelli 82 / Willis and Heymsfield 89 / Schuur and Rutledge 00b +! using kfrag as fragmentation rate (s-1) / 500 microns as char mean diam for max snow mix ratio +! + csmul(:) = 0.0 + qsmul(:) = 0.0 + + IF ( isnwfrac /= 0 ) THEN + do mgs = 1,ngscnt + IF (temg(mgs) .gt. 265.0) THEN !{ + if (xdia(mgs,ls,1) .gt. 100.e-6 .and. xdia(mgs,ls,1) .lt. 2.0e-3) then ! equiv diameter 100microns to 2mm + + tmp = rhoinv(mgs)*pi*xdn(mgs,ls)*cx(mgs,ls)*(500.e-6)**3 + qsmul(mgs) = Max( kfrag*( qx(mgs,ls) - tmp ) , 0.0 ) + + qsmul(mgs) = Min( qxmxd(mgs,li), qsmul(mgs) ) + csmul(mgs) = Min( cxmxd(mgs,li), rho0(mgs)*qsmul(mgs)/mfrag ) + + endif + ENDIF !} + enddo + ENDIF + +! +! frozen rain-rain interaction.... +! +! +! +! +! rain-ice interaction +! +! + do mgs = 1,ngscnt + qracif(mgs) = qraci(mgs) + cracif(mgs) = craci(mgs) +! ciacrf(mgs) = ciacr(mgs) + end do +! +! +! vapor to pristine ice crystals UP +! +! +! +! compute the nucleation rate +! +! do mgs = 1,ngscnt +! idqis = 0 +! if ( ssi(mgs) .gt. 1.0 ) idqis = 1 +! fiinit(mgs) = (felv(mgs)**2)/(cp*rw) +! dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ +! > (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) +! cnnt = min(cnit*exp(-temcg(mgs)*bta1),1.0e+09) +! qiint(mgs) = +! > il5(mgs)*idqis*(1.0*dtpinv) +! < *min((6.88e-13)*cnnt/rho0(mgs), 0.25*dqisdt(mgs)) +! end do +! +! Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation +! + cmassin = cimasn ! 6.88e-13 + do mgs = 1,ngscnt + qiint(mgs) = 0.0 + ciint(mgs) = 0.0 + qicicnt(mgs) = 0.0 + cicint(mgs) = 0.0 + qipipnt(mgs) = 0.0 + cipint(mgs) = 0.0 + ccitmp = 0.0 + IF ( icenucopt == 1 .or. icenucopt == -10 .or. icenucopt == -11 ) THEN + if ( ( temg(mgs) .lt. 268.15 .or. & +! : ( imeyers5 .and. temg(mgs) .lt. 273.0) ) .and. & + & ( imeyers5 .and. temg(mgs) .lt. 272.0 .and. temgkm2(mgs) .lt. tfr) ) .and. & + & ciintmx .gt. (cx(mgs,li)+ccitmp) & +! : .and. cninm(mgs) .gt. 0. & + & ) then + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ & + & (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) + idqis = 0 + if ( ssi(mgs) .gt. 1.0 ) THEN + idqis = 1 + dzfacp = max( float(kgsp(mgs)-kgs(mgs)), 0.0 ) + dzfacm = max( float(kgs(mgs)-kgsm(mgs)), 0.0 ) + qiint(mgs) = & + & idqis*il5(mgs) & + & *(cmassin/rho0(mgs)) & + & *max(0.0,wvel(mgs)) & + & *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs)) & + & /((dzfacp+dzfacm)) + + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + +! +! limit new crystals so it does not increase the current concentration +! above ciintmx 20,000 per liter (2.e7 per m**3) +! +! ciintmx = 1.e9 +! ciintmx = 1.e9 + IF ( icenucopt /= -10 ) THEN + + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(ciint(mgs), ccin(mgs)*dtpinv) ! because ciint is a *rate* + ccin(mgs) = ccin(mgs) - ciint(mgs)*dtp + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ELSEIF ( lcina > 1 ) THEN + ciint(mgs) = Max(0.0, Min( ciint(mgs), Min( cnina(mgs), ciintmx ) - cina(mgs) )) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( icenucopt == 1 .and. ciint(mgs) .gt. Max(0.0, ciintmx - cx(mgs,li) - ccitmp )*dtpinv ) THEN + ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) )*dtpinv + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( icenucopt == -11 .and. dtp*ciint(mgs) .gt. ( cnina(mgs) - (cx(mgs,li) - ccitmp))) THEN + ciint(mgs) = Max(0.0, cnina(mgs) - (cx(mgs,li)+ccitmp)*dtpinv ) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ENDIF + ENDIF + + end if + endif + + ELSEIF ( icenucopt == 2 .or. icenucopt == -1 .or. icenucopt == -2 ) THEN + + IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 1.0 ) .or. ssi(mgs) > 1.25 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) - ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx + ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/(1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + ENDIF + + + + ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 10 ) THEN + IF ( temg(mgs) .lt. 268.15 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) + ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx + ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ENDIF + + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qipipnt(mgs) = qiint(mgs) + cipint(mgs) = ciint(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qicicnt(mgs) = qiint(mgs) + cicint(mgs) = ciint(mgs) + end if +! +! qipipnt(mgs) = 0.0 +! qicicnt(mgs) = qiint(mgs) +! + end do +! +! + +! +! vapor to cloud droplets UP +! + if (ndebug .gt. 0 ) write(0,*) 'dbg = 8' +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: set 3-component' +! +! time for riming.... +! +! rimtim = 240.0 +! dtrim = rimtim +! xacrtim = 120.0 +! tranfr = 0.50 +! tranfw = 0.50 +! +! coefficients for riming +! +! rimc1 = 300.00 +! rimc2 = 0.44 +! +! +! zero som arrays +! +! + do mgs = 1,ngscnt + qrshr(mgs) = 0.0 + qsshrp(mgs) = 0.0 + qhshrp(mgs) = 0.0 + end do +! +! +! first sum all of the shed rain +! +! + do mgs = 1,ngscnt + qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) + crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) + IF ( ipconc .ge. 3 ) THEN +! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) ) + ENDIF + end do +! +! +! + +! +! +! +! + IF ( ipconc .ge. 1 ) THEN +! +! +! concentration production terms +! +! YYY +! +! +! DO mgs = 1,ngscnt + pccwi(:) = 0.0 + pccwd(:) = 0.0 + pccwdacc(:) = 0.0 + pccii(:) = 0.0 + pccin(:) = 0.0 + pccid(:) = 0.0 + pcisi(:) = 0.0 + pcisd(:) = 0.0 + pcrwi(:) = 0.0 + pcrwd(:) = 0.0 + pcswi(:) = 0.0 + pcswd(:) = 0.0 + pchwi(:) = 0.0 + pchwd(:) = 0.0 + pchli(:) = 0.0 + pchld(:) = 0.0 +! ENDDO +! +! Cloud ice +! +! IF ( ipconc .ge. 1 ) THEN + + IF ( warmonly < 0.5 ) THEN + IF ( ffrzs < 1.0 ) THEN + do mgs = 1,ngscnt + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) + + pccii(mgs) = pccii(mgs)*(1.0 - ffrzs) + +! > + nsplinter*(crfrzf(mgs) + crfrz(mgs)) + pccid(mgs) = & + & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & + & -craci(mgs) & + & -csaci(mgs) & + & -chaci(mgs) - chlaci(mgs) & + & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + + + end do + ENDIF ! ffrzs + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + +! qiint(mgs) = 0.0 +! cicint(mgs) = 0.0 +! qicicnt(mgs) = 0.0 + + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) + + pccii(mgs) = pccii(mgs)*(1. - ffrzs) + pccid(mgs) = & +! & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & +! & -craci(mgs) & +! & -csaci(mgs) & +! & -chaci(mgs) - chlaci(mgs) & +! & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + + end do + ENDIF ! warmonly + + +! ENDIF ! ( ipconc .ge. 1 ) +! +! Cloud water +! + IF ( ipconc .ge. 2 ) THEN + + do mgs = 1,ngscnt + pccwi(mgs) = (0.0) ! + (1-il5(mgs))*(-cirmlw(mgs)) + + IF ( warmonly < 0.5 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*(-ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + + ELSEIF ( warmonly < 0.8 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*( & + & -ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & + & ) & + & -cracw(mgs) -chacw(mgs) -chlacw(mgs) + ELSE + +! tmp3d(igs(mgs),jy,kgs(mgs)) = crcnw(mgs) + +! cracw(mgs) = 0.0 ! turn off accretion +! qracw(mgs) = 0.0 +! crcev(mgs) = 0.0 ! turn off evap +! qrcev(mgs) = 0.0 ! turn off evap +! cracr(mgs) = 0.0 ! turn off self collection + + +! cautn(mgs) = 0.0 +! crcnw(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + pccwd(mgs) = & + & - cautn(mgs) -cracw(mgs) + ENDIF + + + IF ( .false. .and. exwmindiam > 0.0 .and. ccwresv(mgs) > 0.0 ) THEN + pccwdacc(mgs) = & + & il5(mgs)*(-ciacw(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + IF ( -pccwdacc(mgs)*dtp .gt. cx(mgs,lc) - ccwresv(mgs) ) THEN + + frac = -(cx(mgs,lc) - ccwresv(mgs) )/(pccwdacc(mgs)*dtp) + pccwdacc(mgs) = -(cx(mgs,lc) - ccwresv(mgs) )*dtpinv + + ciacw(mgs) = frac*ciacw(mgs) + cracw(mgs) = frac*cracw(mgs) + csacw(mgs) = frac*csacw(mgs) + chacw(mgs) = frac*chacw(mgs) + cautn(mgs) = frac*cautn(mgs) + + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + +! resum + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & + & -cwfrzc(mgs)-cwctfzc(mgs) & + & -il5(mgs)*(ciihr(mgs)) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + ENDIF + + ENDIF + + + IF ( -pccwd(mgs)*dtp .gt. cx(mgs,lc) ) THEN +! write(0,*) 'OUCH! pccwd(mgs)*dtp .gt. ccw(mgs) ',pccwd(mgs),cx(mgs,lc) +! write(0,*) 'qc = ',qx(mgs,lc) +! write(0,*) -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs)-cwfrzc(mgs)-cwctfzc(mgs) +! write(0,*) -cracw(mgs) -csacw(mgs) -chacw(mgs) +! write(0,*) - cautn(mgs) + + frac = -cx(mgs,lc)/(pccwd(mgs)*dtp) + pccwd(mgs) = -cx(mgs,lc)*dtpinv + + ciacw(mgs) = frac*ciacw(mgs) + cwfrz(mgs) = frac*cwfrz(mgs) + cwfrzp(mgs) = frac*cwfrzp(mgs) + cwctfzp(mgs) = frac*cwctfzp(mgs) + cwfrzc(mgs) = frac*cwfrzc(mgs) + cwctfzc(mgs) = frac*cwctfzc(mgs) + cwctfz(mgs) = frac*cwctfz(mgs) + cracw(mgs) = frac*cracw(mgs) + csacw(mgs) = frac*csacw(mgs) + chacw(mgs) = frac*chacw(mgs) + cautn(mgs) = frac*cautn(mgs) + + pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs) + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + +! STOP + ENDIF + + end do + + ENDIF ! ipconc + +! +! Rain +! + IF ( ipconc .ge. 3 ) THEN + + do mgs = 1,ngscnt + + IF ( warmonly < 0.5 ) THEN + pcrwi(mgs) = & +! > cracw(mgs) + & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & +! & -csmlr(mgs)/rzxs(mgs) & + & -csmlrr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs)) +! > -csacr(mgs) & + & - chacr(mgs) - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) +! > -il5(mgs)*ciracr(mgs) + ELSEIF ( warmonly < 0.8 ) THEN + pcrwi(mgs) = & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & +! & -csmlr(mgs) & + & -csmlrr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*( - crfrz(mgs) ) & ! - cipacr(mgs)) + & - chacr(mgs) & + & - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) + ELSE + pcrwi(mgs) = & + & crcnw(mgs) + pcrwd(mgs) = & + & +crcev(mgs) & + & - cracr(mgs) + +! tmp3d(igs(mgs),jy,kgs(mgs)) = vtxbar(mgs,lr,1) ! crcnw(mgs) ! (pcrwi(mgs) + pcrwd(mgs)) +! pcrwi(mgs) = 0.0 +! pcrwd(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + ENDIF + + + frac = 0.0 + IF ( -pcrwd(mgs)*dtp .gt. cx(mgs,lr) ) THEN +! write(0,*) 'OUCH! pcrwd(mgs)*dtp .gt. crw(mgs) ',pcrwd(mgs)*dtp,cx(mgs,lr),mgs,igs(mgs),kgs(mgs) +! write(0,*) -ciacr(mgs) +! write(0,*) -crfrz(mgs) +! write(0,*) -chacr(mgs) +! write(0,*) crcev(mgs) +! write(0,*) -cracr(mgs) + + frac = -cx(mgs,lr)/(pcrwd(mgs)*dtp) + pcrwd(mgs) = -cx(mgs,lr)*dtpinv + + ciacr(mgs) = frac*ciacr(mgs) + ciacrf(mgs) = frac*ciacrf(mgs) + ciacrs(mgs) = frac*ciacrs(mgs) + crfrz(mgs) = frac*crfrz(mgs) + crfrzf(mgs) = frac*crfrzf(mgs) + crfrzs(mgs) = frac*crfrzs(mgs) + chacr(mgs) = frac*chacr(mgs) + chlacr(mgs) = frac*chlacr(mgs) + crcev(mgs) = frac*crcev(mgs) + cracr(mgs) = frac*cracr(mgs) + +! STOP + ENDIF + + end do + + ENDIF + + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + IF ( ipconc .ge. 4 ) THEN ! + + do mgs = 1,ngscnt + pcswi(mgs) = & + & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & + & + cwfrz2snowfrac*cwfrz(mgs)/cwfrz2snowratio & + & + cscnh(mgs) + + IF ( ffrzs > 0.0 ) THEN + pcswi(mgs) = pcswi(mgs) + ffrzs* ( & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) ) + ENDIF + + + IF ( ess0 < 0.0 ) THEN + csacs(mgs) = Max(0.0, csacs(mgs) - (ifrzs)*(crfrzs(mgs) + ciacrs(mgs))) + ENDIF + + pcswd(mgs) = & +! : cracs(mgs) & + & -chacs(mgs) - chlacs(mgs) & + & -chcns(mgs) & + & +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & ! + csshrp(mgs) +! > +il5(mgs)*(cssbv(mgs)) & + & + cssbv(mgs) & + & - csacs(mgs) + + frac = 0.0 + IF ( imixedphase == 0 ) THEN + IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN + frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp) + + pqswd(mgs) = frac*pqswd(mgs) + + chacs(mgs) = frac*chacs(mgs) + chlacs(mgs) = frac*chlacs(mgs) + chcns(mgs) = frac*chcns(mgs) + csmlr(mgs) = frac*csmlr(mgs) + csshr(mgs) = frac*csshr(mgs) + cssbv(mgs) = frac*cssbv(mgs) + csacs(mgs) = frac*csacs(mgs) + + ENDIF + ENDIF + + + + pccii(mgs) = pccii(mgs) & + & + (1. - ifrzs)*crfrzs(mgs) & + & + (1. - ifrzs)*ciacrs(mgs) + + pcswi(mgs) = pcswi(mgs) & + & + (ifrzs)*crfrzs(mgs) & + & + (ifrzs)*ciacrs(mgs) + + end do + + ENDIF + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +(ifrzg*crfrzf(mgs) & + & +il5(mgs)*ifiacrg*(ciacrf(mgs) )) & + & + chcnsh(mgs) + chcnih(mgs) + chcnhl(mgs) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & +! > + il5(mgs)*chsbv(mgs) & + & + chsbv(mgs) & + & - il5(mgs)*chlcnh(mgs) & + & - cscnh(mgs) + end do +! + +! +! Hail +! + IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = ((1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*(1.0-ifiacrg)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhlh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) & +! > + il5(mgs)*chlsbv(mgs) & + & + chlsbv(mgs) - chcnhl(mgs) + + IF ( imixedphase == 0 ) THEN + frac = 0.0 + IF ( cx(mgs,lhl) + dtp*(pchli(mgs) + pchld(mgs)) < 0.0 ) THEN + ! rescale depletion + + frac = (-cx(mgs,lhl) + pchli(mgs)*dtp)/(pchld(mgs)*dtp) + + chlmlr(mgs) = frac*chlmlr(mgs) + chlsbv(mgs) = frac*chlsbv(mgs) + chcnhl(mgs) = frac*chcnhl(mgs) + + pchld(mgs) = frac*pchld(mgs) + + ENDIF + ENDIF + end do + + ENDIF +! + + ENDIF ! (ipconc .ge. 5 ) + + ELSEIF ( warmonly < 0.8 ) THEN + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +ifrzg*(crfrzf(mgs) ) ! +il5(mgs)*(ciacrf(mgs) )) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & + & - il5(mgs)*chlcnh(mgs) + end do +! +! Hail +! + IF ( lhl .gt. 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs)) & ! +il5(mgs)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhl(mgs)/rzxh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) ! & +! > + il5(mgs)*chlsbv(mgs) & +! & + chlsbv(mgs) + +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF + end do + + ENDIF + + ENDIF ! ipconc >= 5 + + ENDIF ! warmonly + +! + +! +! Balance and checks for continuity.....within machine precision... +! + do mgs = 1,ngscnt + pctot(mgs) = pccwi(mgs) +pccwd(mgs) + & + & pccii(mgs) +pccid(mgs) + & + & pcrwi(mgs) +pcrwd(mgs) + & + & pcswi(mgs) +pcswd(mgs) + & + & pchwi(mgs) +pchwd(mgs) + & + & pchli(mgs) +pchld(mgs) + end do +! +! + ENDIF ! ( ipconc .ge. 1 ) +! +! +! +! +! +! GOGO +! production terms for mass +! +! + pqwvi(:) = 0.0 + pqwvd(:) = 0.0 + pqcwi(:) = 0.0 + pqcwd(:) = 0.0 + pqcwdacc(:) = 0.0 + pqcii(:) = 0.0 + pqcid(:) = 0.0 + pqrwi(:) = 0.0 + pqrwd(:) = 0.0 + pqswi(:) = 0.0 + pqswd(:) = 0.0 + pqhwi(:) = 0.0 + pqhwd(:) = 0.0 + pqhli(:) = 0.0 + pqhld(:) = 0.0 + pqlwsi(:) = 0.0 + pqlwsd(:) = 0.0 + pqlwhi(:) = 0.0 + pqlwhd(:) = 0.0 + pqlwlghi(:) = 0.0 + pqlwlghd(:) = 0.0 + pqlwlghli(:) = 0.0 + pqlwlghld(:) = 0.0 + pqlwhli(:) = 0.0 + pqlwhld(:) = 0.0 +! +! Vapor +! + IF ( warmonly < 0.5 ) THEN + do mgs = 1,ngscnt + +! NOTE: ANY CHANGES HERE ALSO NEED TO GO INTO THE RESUM FARTHER DOWN! + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + + end do + + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -il5(mgs)*qisbv(mgs) + pqwvd(mgs) = & + & +il5(mgs)*(-qiint(mgs) & +! & -qhdpv(mgs) ) & !- qhldpv(mgs)) & + & -qhdpv(mgs) - qhldpv(mgs)) & +! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -Max(0.0, qrcev(mgs)) & + & -il5(mgs)*qidpv(mgs) + end do + + ELSE + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) + end do + + ENDIF ! warmonly +! +! Cloud water +! + do mgs = 1,ngscnt + + pqcwi(mgs) = (0.0) + qwcnr(mgs) + + IF ( warmonly < 0.5 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & + & -il5(mgs)*(qiihr(mgs)) & + & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) !& +! & -il5(mgs)*(qwfrzp(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & + & -il5(mgs)*(qiihr(mgs)) & + & -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs) + ELSE + pqcwd(mgs) = & + & -qracw(mgs) - qrcnw(mgs) + ENDIF + + + IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN + + frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp) + pqcwd(mgs) = -qx(mgs,lc)*dtpinv + + qiacw(mgs) = frac*qiacw(mgs) +! qwfrzp(mgs) = frac*qwfrzp(mgs) +! qwctfzp(mgs) = frac*qwctfzp(mgs) + qwfrzc(mgs) = frac*qwfrzc(mgs) + qwfrzis(mgs) = frac*qwfrzis(mgs) + qwfrz(mgs) = frac*qwfrz(mgs) + qwctfzc(mgs) = frac*qwctfzc(mgs) + qwctfzis(mgs) = frac*qwctfzis(mgs) + qwctfz(mgs) = frac*qwctfz(mgs) + qracw(mgs) = frac*qracw(mgs) + qsacw(mgs) = frac*qsacw(mgs) + qhacw(mgs) = frac*qhacw(mgs) + vhacw(mgs) = frac*vhacw(mgs) + qrcnw(mgs) = frac*qrcnw(mgs) + qwfrzp(mgs) = frac*qwfrzp(mgs) + IF ( lhl .gt. 1 ) THEN + qhlacw(mgs) = frac*qhlacw(mgs) + vhlacw(mgs) = frac*vhlacw(mgs) + ENDIF +! IF ( lzh .gt. 1 ) zhacw(mgs) = frac*zhacw(mgs) + +! STOP + ENDIF + + + end do +! +! Cloud ice +! + IF ( warmonly < 0.5 ) THEN + + do mgs = 1,ngscnt + IF ( ffrzs < 1.0 ) THEN + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs)) & + & +il5(mgs)*(qicichr(mgs)) & + & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) +! > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + ENDIF + + pqcii(mgs) = pqcii(mgs)*(1.0 - ffrzs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) + + pqcid(mgs) = & + & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & + & -qraci(mgs) & + & -qsaci(mgs) ) & + & -qhaci(mgs) & + & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) & + & - qhcni(mgs) + end do + + + ELSEIF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs)*(1. - ffrzs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs))*(1. - ffrzs) & + & +il5(mgs)*(qicichr(mgs))*(1. - ffrzs) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) ! & ! (qiacwi(mgs)+qwacii(mgs)) & +! & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & +! & +qhmul1(mgs) + qhlmul1(mgs) & +! & + qsplinter(mgs) + qsplinter2(mgs) + + pqcid(mgs) = & +! & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & +! & -qraci(mgs) & +! & -qsaci(mgs) ) & +! & -qhaci(mgs) & +! & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) ! & +! & - qhcni(mgs) + end do + + ENDIF +! +! Rain +! + + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhmlr(mgs) & !null at this point when wet snow/graupel included + & -qsmlr(mgs) - qhlmlr(mgs) & + & -qimlr(mgs)) & + & -qsshr(mgs) & !null at this point when wet snow/graupel included + & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & + & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhmlr(mgs) & !null at this point when wet snow/graupel included + & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlmlr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) ) !null at this point when wet snow/graupel included + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + + + ! IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + + frac = (-qx(mgs,lr) + pqrwi(mgs)*dtp)/(pqrwd(mgs)*dtp) +! pqrwd(mgs) = -qx(mgs,lr)*dtpinv + pqrwi(mgs) + + pqwvi(mgs) = pqwvi(mgs) & + & + Min(0.0, qrcev(mgs)) & + & - frac*Min(0.0, qrcev(mgs)) + pqwvd(mgs) = pqwvd(mgs) & + & + Max(0.0, qrcev(mgs)) & + & - frac*Max(0.0, qrcev(mgs)) + + qiacr(mgs) = frac*qiacr(mgs) + qiacrf(mgs) = frac*qiacrf(mgs) + qiacrs(mgs) = frac*qiacrs(mgs) + viacrf(mgs) = frac*viacrf(mgs) + qrfrz(mgs) = frac*qrfrz(mgs) + qrfrzs(mgs) = frac*qrfrzs(mgs) + qrfrzf(mgs) = frac*qrfrzf(mgs) + vrfrzf(mgs) = frac*vrfrzf(mgs) + qsacr(mgs) = frac*qsacr(mgs) + qhacr(mgs) = frac*qhacr(mgs) + vhacr(mgs) = frac*vhacr(mgs) + qrcev(mgs) = frac*qrcev(mgs) + qhlacr(mgs) = frac*qhlacr(mgs) + vhlacr(mgs) = frac*vhlacr(mgs) +! qhcev(mgs) = frac*qhcev(mgs) + + + IF ( warmonly < 0.5 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs)) & + & - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + +! +! Resum for vapor since qrcev has changed +! + IF ( qrcev(mgs) .ne. 0.0 ) THEN + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + + ENDIF + + +! STOP + ENDIF + end do + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + do mgs = 1,ngscnt + pqswi(mgs) = & + & il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) & + & + ifrzs*(qiacrs(mgs) + qrfrzs(mgs)) & + & + il5(mgs)*(( qwfrzc(mgs) + qwctfzc(mgs) + qicichr(mgs) )*ffrzs & + & + (1.0 - ffrzs)*cwfrz2snowfrac*qwfrz(mgs) ) & + & + il2(mgs)*qsacr(mgs)) & + & + il5(mgs)*qicicnt(mgs)*ffrzs & + & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & ! only applies for ipconc <= 3 + & + Max(0.0, qscev(mgs)) & + & + qsacw(mgs) + qscnh(mgs) & + & + ffrzs*(qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs)) + pqswd(mgs) = & +! > -qfacs(mgs) ! -qwacs(mgs) & + & -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs) & + & -qhcns(mgs) & + & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included +! > +il5(mgs)*(qssbv(mgs)) & + & + (qssbv(mgs)) & + & + Min(0.0, qscev(mgs)) & + & -qsmul(mgs) + + + IF ( imixedphase == 0 .and. pqswd(mgs) .lt. 0.0 ) THEN + IF ( qx(mgs,ls) + dtp*(pqswi(mgs) + pqswd(mgs)) < 0.0 ) THEN + frac = (-qx(mgs,ls) + pqswi(mgs)*dtp)/(pqswd(mgs)*dtp) + + pqswd(mgs) = frac*pqswd(mgs) + + qracs(mgs) = frac*qracs(mgs) ! only used for single moment at this time + qhacs(mgs) = frac*qhacs(mgs) + qhlacs(mgs) = frac*qhlacs(mgs) + qhcns(mgs) = frac*qhcns(mgs) + qsmlr(mgs) = frac*qsmlr(mgs) + qsshr(mgs) = frac*qsshr(mgs) + qssbv(mgs) = frac*qssbv(mgs) + qsmul(mgs) = frac*qsmul(mgs) + IF ( qscev(mgs) < 0.0 ) qscev(mgs) = frac*qscev(mgs) + + ENDIF + ENDIF + + pqcii(mgs) = pqcii(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & + (1. - ifrzs)*qiacrs(mgs) + + end do + +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*(ifrzg*qrfrzf(mgs) + (1-il3(mgs))*(ifiacrg)*(qiacrf(mgs)+qracif(mgs))) & + & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & + & +il5(mgs)*(qhdpv(mgs)) & + & +Max(0.0, qhcev(mgs)) & + & +qhacr(mgs)+qhacw(mgs) & + & +qhacs(mgs)+qhaci(mgs) & + & + qhcns(mgs) + qhcni(mgs) + qhcnhl(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & +(1-il5(mgs))*qhmlr(mgs) & !null at this point when wet graupel included +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) - qhlcnh(mgs) - qscnh(mgs) & + & - qsplinter(mgs) - qsplinter2(mgs) +! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + end do + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) + ((1.0-ifrzg)*qrfrzf(mgs) + (1.0-ifiacrg)*(qiacrf(mgs)+ qracif(mgs)))) & + & +Max(0.0, qhlcev(mgs)) & + & +qhlacr(mgs)+qhlacw(mgs) & + & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + IF ( imixedphase == 0 ) THEN + frac = 0.0 + IF ( qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs)) < 0.0 ) THEN + ! rescale depletion + + frac = (-qx(mgs,lhl) + pqhli(mgs)*dtp)/(pqhld(mgs)*dtp) + + qhlmlr(mgs) = frac*qhlmlr(mgs) + qhlsbv(mgs) = frac*qhlsbv(mgs) + qhcnhl(mgs) = frac*qhcnhl(mgs) + qhlmul1(mgs) = frac*qhlmul1(mgs) + IF ( qhlcev(mgs) < 0.0 ) qhlcev(mgs) = frac*qhlcev(mgs) + + pqhld(mgs) = frac*pqhld(mgs) + + ENDIF + ENDIF + + + end do + + ENDIF ! lhl + + ELSEIF ( warmonly < 0.8 ) THEN +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) & + & +il5(mgs)*(qhdpv(mgs)) & + & +qhacr(mgs)+qhacw(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & - qhlcnh(mgs) & + & - qhmul1(mgs) & + & - qsplinter(mgs) - qsplinter2(mgs) & + & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included + end do + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & + & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & + & +qhlacr(mgs)+qhlacw(mgs) & +! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + end do + + ENDIF ! lhl + + ENDIF ! warmonly + +! +! Liquid water on snow and graupel +! + + vhmlr(:) = 0.0 + vhlmlr(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel + +! vhshdr(:) = 0.0 + vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation +! vhsoak(:) = 0.0 + +! vhlshdr(:) = 0.0 + vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation +! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) +! vhlsoak(:) = 0.0 + + ENDIF ! mixedphase + + + +! +! Snow volume +! + IF ( lvol(ls) .gt. 1 ) THEN + do mgs = 1,ngscnt +! pvswi(mgs) = rho0(mgs)*( pqswi(mgs) )/xdn0(ls) + + pvswi(mgs) = rho0(mgs)*( & +!aps > il5*qsfzs(mgs)/xdn(mgs,ls) & +!aps > -il5*qsfzs(mgs)/xdn(mgs,lr) & + & +il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) + (1. - ifrzs)*qiacrs(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & )/xdn0(ls) & + & + (qsacr(mgs))/rimdn(mgs,ls) ) + vsacw(mgs) +! > + (qsacw(mgs) + qsacr(mgs))/rimdn(mgs,ls) ) + pvswd(mgs) = rho0(mgs)*( pqswd(mgs) )/xdn0(ls) & +! > -qhacs(mgs) +! > -qhcns(mgs) +! > +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) +! > +il5(mgs)*(qssbv(mgs)) + & -rho0(mgs)*qsmul(mgs)/xdn0(ls) +!aps > +rho0(mgs)*(1-il5(mgs))*( +!aps > qsmlr(mgs)/xdn(mgs,ls) +!aps > +(qscev-qsmlr(mgs))/xdn(mgs,lr) ) + end do + +!aps IF (mixedphase) THEN +!aps pvswd(mgs) = pvswd(mgs) +!aps > + rho0(mgs)*qsshr(mgs)/xdn(mgs,lr) +!aps ENDIF + + ENDIF +! +! Graupel volume +! + IF ( lvol(lh) .gt. 1 ) THEN + DO mgs = 1,ngscnt +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) )/xdn0(lh) ) + +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) - il5(mgs)*qrfrzf(mgs) )/xdn0(lh) ! +! : + il5(mgs)*qrfrzf(mgs)/rhofrz ) + + pvhwi(mgs) = rho0(mgs)*( & + & +il5(mgs)*( ifiacrg*qracif(mgs))/rhofrz & +!erm > + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)? & + & + ( il5(mgs)*qhdpv(mgs)/qhdpvdn & + & + (qhacs(mgs) + qhaci(mgs))/qhacidn ) ) & + & + rho0(mgs)*Max(0.0, qhcev(mgs))/1000. & ! only used in mixed phase: evaporation/condensation of liquid water coating +! > + qhacs(mgs) + qhaci(mgs) )/xdn0(ls) ) & + & + vhcns(mgs) & + & + vhacr(mgs) + vhacw(mgs) + vhfzh(mgs) & ! qhacw(mgs)/rimdn(mgs,lh) +! > + vhfrh(mgs) & + & + vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs)) +! > +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh) + +! pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh) + + pvhwd(mgs) = rho0(mgs)*( & +! > qhshr(mgs)/xdn0(lr) & +! > - il5(mgs)*qhfzh(mgs)/xdn(mgs,lr) & + & +( (1-il5(mgs))*vhmlr(mgs) & +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) )/xdn(mgs,lh) ) & + & - vhlcnh(mgs) + vhshdr(mgs) - vhsoak(mgs) - vscnh(mgs) + +! IF (mixedphase) THEN +! pvhwd(mgs) = pvhwd(mgs) +! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) +! ENDIF + + IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN + + write(iunit,*) + write(iunit,*) 'Graupel at ',igs(mgs),kgs(mgs) +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) 'qhcns',qhcns(mgs) + write(iunit,*) 'qhcni',qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) 'qhacr ',qhacr(mgs) + write(iunit,*) 'qhacw', qhacw(mgs) + write(iunit,*) 'qhacs', qhacs(mgs) + write(iunit,*) 'qhaci', qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) 'qhcev',qhcev(mgs) + write(iunit,*) + write(iunit,*) 'qhshr',qhshr(mgs) + write(iunit,*) 'qhmlr', (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) 'qhsbv', qhsbv(mgs) + write(iunit,*) 'qhlcnh',-qhlcnh(mgs) + write(iunit,*) 'qhmul1',-qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) + write(iunit,*) 'Volume' + write(iunit,*) + write(iunit,*) 'pvhwi',pvhwi(mgs) + write(iunit,*) 'vhcns', vhcns(mgs) + write(iunit,*) 'vhacr,vhacw',vhacr(mgs), vhacw(mgs) ! qhacw(mgs)/rimdn(mgs,lh) + write(iunit,*) 'vhcni',vhcni(mgs) + write(iunit,*) + write(iunit,*) 'pvhwd',pvhwd(mgs) + write(iunit,*) 'vhlcnh,vhshdr,vhsoak ', vhlcnh(mgs), vhshdr(mgs), vhsoak(mgs) + write(iunit,*) 'vhmlr', vhmlr(mgs) + write(iunit,*) +! write(iunit,*) +! write(iunit,*) +! write(iunit,*) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + + + ENDIF + + + ENDDO + + ENDIF +! +! +! + +! +! Hail volume +! + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + DO mgs = 1,ngscnt + + pvhli(mgs) = rho0(mgs)*( & + & + ( il5(mgs)*(((1.0-ifiacrg)*qracif(mgs))/rhofrz + qhldpv(mgs) ) & +! & + Max(0.0, qhlcev(mgs)) & +! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) ) & ! xdn0(ls) ) & +! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose + & + qhlacs(mgs) + qhlaci(mgs) )/500. ) & ! changed to 500 instead of min graupel density to keep hail density from dropping too much + & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & + & + vhlcnhl(mgs) + ((1.0-ifiacrg)*viacrf(mgs) + (1.0-ifrzg)*vrfrzf(mgs)) & + & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl) + + pvhld(mgs) = rho0(mgs)*( & + & +( qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) )/xdn(mgs,lhl) ) & +! & + vhlmlr(mgs) & + & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & + & + vhlshdr(mgs) - vhlsoak(mgs) + + + ENDDO + + ENDIF + ENDIF + + + if ( ndebug .ge. 1 ) then + do mgs = 1,ngscnt +! + ptotal(mgs) = 0. + ptotal(mgs) = ptotal(mgs) & + & + pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) +! + + + ENDDO + + do mgs = 1,ngscnt + + if ( ( (ndebug .ge. 0 ) .and. abs(ptotal(mgs)) .gt. eqtot ) & +! if ( ( abs(ptotal(mgs)) .gt. eqtot ) +! : .or. pqswi(mgs)*dtp .gt. 1.e-3 +! : .or. pqhwi(mgs)*dtp .gt. 1.e-3 +! : .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3 +! : .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7 +! : .or. dtp*(pcipi(mgs)+pcipd(mgs)) .gt. 1.e7 & + & .or. .not. (ptotal(mgs) .lt. 1.0 .and. ptotal(mgs) .gt. -1.0) & ! this line is basically checking for NaNs + & ) then + write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs, & + & kgs(mgs),ptotal(mgs) + + write(iunit,*) 't7: ', t7(igs(mgs),jgs,kgs(mgs)) + write(iunit,*) 'cci,ccw,crw,rdia: ',cx(mgs,li),cx(mgs,lc),cx(mgs,lr),0.5*xdia(mgs,lr,1) + write(iunit,*) 'qc,qi,qr : ',qx(mgs,lc),qx(mgs,li),qx(mgs,lr) + write(iunit,*) 'rmas, qrcalc : ',xmas(mgs,lr),xmas(mgs,lr)*cx(mgs,lr)/rho0(mgs) + write(iunit,*) 'vti,vtc,eiw,vtr: ',vtxbar(mgs,li,1),vtxbar(mgs,lc,1),eiw(mgs),vtxbar(mgs,lr,1) + write(iunit,*) 'cidia,cwdia,qcmxd: ', xdia(mgs,li,1),xdia(mgs,lc,1),qcmxd(mgs) + write(iunit,*) 'snow: ',qx(mgs,ls),cx(mgs,ls),swvent(mgs),vtxbar(mgs,ls,1),xdia(mgs,ls,1) + write(iunit,*) 'graupel: ',qx(mgs,lh),cx(mgs,lh),hwvent(mgs),vtxbar(mgs,lh,1),xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) write(iunit,*) 'hail: ',qx(mgs,lhl),cx(mgs,lhl),hlvent(mgs),vtxbar(mgs,lhl,1),xdia(mgs,lhl,1) + + + write(iunit,*) 'li: ',xdia(mgs,li,1),xdia(mgs,li,2),xmas(mgs,li),qx(mgs,li), & + & vtxbar(mgs,li,1) + + + write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr) + write(iunit,*) 'temcg = ', temcg(mgs) + + write(iunit,*) 'v ', pqwvi(mgs) ,pqwvd(mgs) + write(iunit,*) 'c ', pqcwi(mgs) ,pqcwd(mgs) + write(iunit,*) 'ci', pqcii(mgs) ,pqcid(mgs) + write(iunit,*) 'r ', pqrwi(mgs) ,pqrwd(mgs) + write(iunit,*) 's ', pqswi(mgs) ,pqswd(mgs) + write(iunit,*) 'h ', pqhwi(mgs) ,pqhwd(mgs) + write(iunit,*) 'hl', pqhli(mgs) ,pqhld(mgs) + tmp = pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) + + write(iunit,*) 'total = ',tmp + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + +! +! print production terms +! + write(iunit,*) + write(iunit,*) 'Vapor' +! + write(iunit,*) -Min(0.0,qrcev(mgs)) + write(iunit,*) -il5(mgs)*qhsbv(mgs) + write(iunit,*) -il5(mgs)*qhlsbv(mgs) + write(iunit,*) -il5(mgs)*qssbv(mgs) + write(iunit,*) -il5(mgs)*qisbv(mgs) + write(iunit,*) 'pqwvi= ', pqwvi(mgs) + write(iunit,*) -Max(0.0,qrcev(mgs)) + write(iunit,*) -Max(0.0,qhcev(mgs)) + write(iunit,*) -Max(0.0,qhlcev(mgs)) + write(iunit,*) -Max(0.0,qscev(mgs)) + write(iunit,*) -il5(mgs)*qiint(mgs) + write(iunit,*) -il5(mgs)*qhdpv(mgs) + write(iunit,*) -il5(mgs)*qhldpv(mgs) + write(iunit,*) -il5(mgs)*qsdpv(mgs) + write(iunit,*) -il5(mgs)*qidpv(mgs) + write(iunit,*) 'pqwvd = ', pqwvd(mgs) +! + write(iunit,*) + write(iunit,*) 'Cloud ice' +! + write(iunit,*) il5(mgs)*qicicnt(mgs) + write(iunit,*) il5(mgs)*qidpv(mgs) + write(iunit,*) il5(mgs)*qiacw(mgs) + write(iunit,*) il5(mgs)*qwfrzc(mgs) + write(iunit,*) il5(mgs)*qwctfzc(mgs) + write(iunit,*) il5(mgs)*qicichr(mgs) + write(iunit,*) qhmul1(mgs) + write(iunit,*) qhlmul1(mgs) + write(iunit,*) 'pqcii = ', pqcii(mgs) + write(iunit,*) -il5(mgs)*qscni(mgs) + write(iunit,*) -il5(mgs)*qscnvi(mgs) + write(iunit,*) -il5(mgs)*qraci(mgs) + write(iunit,*) -il5(mgs)*qsaci(mgs) + write(iunit,*) -il5(mgs)*qhaci(mgs) + write(iunit,*) -il5(mgs)*qhlaci(mgs) + write(iunit,*) il5(mgs)*qisbv(mgs) + write(iunit,*) (1.-il5(mgs))*qimlr(mgs) + write(iunit,*) -il5(mgs)*qhcni(mgs) + write(iunit,*) 'pqcid = ', pqcid(mgs) + write(iunit,*) ' Conc:' + write(iunit,*) pccii(mgs),pccid(mgs) + write(iunit,*) il5(mgs),cicint(mgs) + write(iunit,*) cwacii(mgs),cwfrzc(mgs),cwctfzc(mgs) + write(iunit,*) cicichr(mgs) + write(iunit,*) chmul1(mgs) + write(iunit,*) chlmul1(mgs) + write(iunit,*) csmul(mgs) +! +! +! +! + write(iunit,*) + write(iunit,*) 'Cloud water' +! + write(iunit,*) 'pqcwi =', pqcwi(mgs) + write(iunit,*) -il5(mgs)*qiacw(mgs) + write(iunit,*) -il5(mgs)*qwfrzc(mgs) + write(iunit,*) -il5(mgs)*qwctfzc(mgs) + write(iunit,*) -il5(mgs)*qwctfzis(mgs) +! write(iunit,*) -il5(mgs)*qwfrzp(mgs) +! write(iunit,*) -il5(mgs)*qwctfzp(mgs) + write(iunit,*) -il5(mgs)*qiihr(mgs) + write(iunit,*) -il5(mgs)*qicichr(mgs) + write(iunit,*) -il5(mgs)*qipiphr(mgs) + write(iunit,*) -qracw(mgs) + write(iunit,*) -qsacw(mgs) + write(iunit,*) -qrcnw(mgs) + write(iunit,*) -qhacw(mgs) + write(iunit,*) -qhlacw(mgs) + write(iunit,*) 'pqcwd = ', pqcwd(mgs) + + + write(iunit,*) + write(iunit,*) 'Concentration:' + write(iunit,*) -cautn(mgs) + write(iunit,*) -cracw(mgs) + write(iunit,*) -csacw(mgs) + write(iunit,*) -chacw(mgs) + write(iunit,*) -ciacw(mgs) + write(iunit,*) -cwfrzp(mgs) + write(iunit,*) -cwctfzp(mgs) + write(iunit,*) -cwfrzc(mgs) + write(iunit,*) -cwctfzc(mgs) + write(iunit,*) pccwd(mgs) +! + write(iunit,*) + write(iunit,*) 'Rain ' +! + write(iunit,*) qracw(mgs) + write(iunit,*) qrcnw(mgs) + write(iunit,*) Max(0.0, qrcev(mgs)) + write(iunit,*) -(1-il5(mgs))*qhmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qsmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qimlr(mgs) + write(iunit,*) -qrshr(mgs) + write(iunit,*) 'pqrwi = ', pqrwi(mgs) + write(iunit,*) -qsshr(mgs) + write(iunit,*) -qhshr(mgs) + write(iunit,*) -qhlshr(mgs) + write(iunit,*) -il5(mgs)*qiacr(mgs),qiacr(mgs), qiacrf(mgs) + write(iunit,*) -il5(mgs)*qrfrz(mgs) + write(iunit,*) -qsacr(mgs) + write(iunit,*) -qhacr(mgs) + write(iunit,*) -qhlacr(mgs) + write(iunit,*) qrcev(mgs) + write(iunit,*) 'pqrwd = ', pqrwd(mgs) + write(iunit,*) 'fhw, fhlw = ',fhw(mgs),fhlw(mgs) + write(iunit,*) 'qrzfac = ', qrzfac(mgs) +! + + write(iunit,*) + write(iunit,*) 'Rain concentration' + write(iunit,*) pcrwi(mgs) + write(iunit,*) crcnw(mgs) + write(iunit,*) 1-il5(mgs) + write(iunit,*) -chmlr(mgs),-csmlr(mgs) + write(iunit,*) -crshr(mgs) + write(iunit,*) pcrwd(mgs) + write(iunit,*) il5(mgs) + write(iunit,*) -ciacr(mgs),-crfrz(mgs) + write(iunit,*) -csacr(mgs),-chacr(mgs) + write(iunit,*) +crcev(mgs) + write(iunit,*) cracr(mgs) +! write(iunit,*) -il5(mgs)*ciracr(mgs) + + + write(iunit,*) + write(iunit,*) 'Snow' +! + write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs) + write(iunit,*) il5(mgs)*qsaci(mgs) + write(iunit,*) il5(mgs)*qrfrzs(mgs) + write(iunit,*) il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs) + write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs) + write(iunit,*) qsacw(mgs) + write(iunit,*) qsacr(mgs), qscnh(mgs) + write(iunit,*) 'pqswi = ',pqswi(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) -qracs(mgs) + write(iunit,*) -qhacs(mgs) + write(iunit,*) -qhlacs(mgs) + write(iunit,*) (1-il5(mgs))*qsmlr(mgs) + write(iunit,*) qsshr(mgs) +! write(iunit,*) qsshrp(mgs) + write(iunit,*) il5(mgs)*(qssbv(mgs)) + write(iunit,*) 'pqswd = ', pqswd(mgs) + write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) + write(iunit,*) (qssbv(mgs)) + write(iunit,*) Min(0.0, qscev(mgs)) + write(iunit,*) -qsmul(mgs) +! +! + write(iunit,*) + write(iunit,*) 'Graupel' +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) qhcns(mgs) + write(iunit,*) qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) qhacr(mgs) + write(iunit,*) qhacw(mgs) + write(iunit,*) qhacs(mgs) + write(iunit,*) qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) qhshr(mgs) + write(iunit,*) (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) il5(mgs),qhsbv(mgs) + write(iunit,*) -qhlcnh(mgs) + write(iunit,*) -qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + +! + write(iunit,*) + write(iunit,*) 'Hail' +! + write(iunit,*) qhlcnh(mgs) + write(iunit,*) il5(mgs)*(qhldpv(mgs)) + write(iunit,*) qhlacr(mgs) + write(iunit,*) qhlacw(mgs) + write(iunit,*) qhlacs(mgs) + write(iunit,*) qhlaci(mgs) + write(iunit,*) pqhli(mgs) + write(iunit,*) + write(iunit,*) qhlshr(mgs) + write(iunit,*) (1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) il5(mgs)*qhlsbv(mgs) + write(iunit,*) pqhld(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchli(mgs),pchld(mgs) + write(iunit,*) chlcnh(mgs) +! +! Balance and checks for continuity.....within machine precision... +! +! + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + write(iunit,*) 'PTOTAL',ptotal(mgs) +! + end if ! ptotal out of bounds or NaN +! + end do +! + + end if ! ( nstep/12*12 .eq. nstep ) + +! +! latent heating from phase changes (except qcw, qci cond, and evap) +! + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*(1-imixedphase)*( & + & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & + & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & + & +qsshr(mgs) & + & +qhshr(mgs) & + & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) & + & ) & + & +il5(mgs)*(qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs)) + pmlt(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) + ! NOTE: psub is sum of sublimation and deposition + psub(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + pevap(mgs) = & + & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) + ! NOTE: pdep is the deposition part only + pdep(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*( & + & +qhshr(mgs) & + & +qhlshr(mgs) & + & +qrfrz(mgs)+qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs) & + & +qhacw(mgs) + qhlacw(mgs) & + & +qhacr(mgs) + qhlacr(mgs) ) + psub(mgs) = 0.0 + & + & il5(mgs)*( & + & + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) + ELSE + pfrz(mgs) = 0.0 + psub(mgs) = 0.0 + pvap(mgs) = qrcev(mgs) + ENDIF ! warmonly + ptem(mgs) = & + & (1./pi0(mgs))* & + & (felfcp(mgs)*pfrz(mgs) & + & +felscp(mgs)*psub(mgs) & + & +felvcp(mgs)*pvap(mgs)) + thetap(mgs) = thetap(mgs) + dtp*ptem(mgs) + ptem2(mgs) = ptem(mgs) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (felfpi(mgs)*pfrz(mgs) & + & +felspi(mgs)*psub(mgs) & + & +felvpi(mgs)*pvap(mgs))*dtp + ENDIF + end do + + + + +! +! sum the sources and sinks for qwvp, qcw, qci, qrw, qsw +! +! + do mgs = 1,ngscnt + qwvp(mgs) = qwvp(mgs) + & + & dtp*(pqwvi(mgs)+pqwvd(mgs)) + qx(mgs,lc) = qx(mgs,lc) + & + & dtp*(pqcwi(mgs)+pqcwd(mgs)) + qx(mgs,lr) = qx(mgs,lr) + & + & dtp*(pqrwi(mgs)+pqrwd(mgs)) + qx(mgs,li) = qx(mgs,li) + & + & dtp*(pqcii(mgs)+pqcid(mgs)) + qx(mgs,ls) = qx(mgs,ls) + & + & dtp*(pqswi(mgs)+pqswd(mgs)) + qx(mgs,lh) = qx(mgs,lh) + & + & dtp*(pqhwi(mgs)+pqhwd(mgs)) + IF ( lhl .gt. 1 ) THEN + qx(mgs,lhl) = qx(mgs,lhl) + & + & dtp*(pqhli(mgs)+pqhld(mgs)) + ENDIF + + + end do + +! sum sources for particle volume + + IF ( ldovol ) THEN + + do mgs = 1,ngscnt + + IF ( lvol(ls) .gt. 1 ) THEN + vx(mgs,ls) = vx(mgs,ls) + & + & dtp*(pvswi(mgs)+pvswd(mgs)) + ENDIF + + IF ( lvol(lh) .gt. 1 ) THEN + vx(mgs,lh) = vx(mgs,lh) + & + & dtp*(pvhwi(mgs)+pvhwd(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + vx(mgs,lhl) = vx(mgs,lhl) + & + & dtp*(pvhli(mgs)+pvhld(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + ENDIF + + ENDDO + + ENDIF ! ldovol + +! +! +! +! concentrations +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = cx(mgs,li) + & + & dtp*(pccii(mgs)+pccid(mgs)) + cina(mgs) = cina(mgs) + pccin(mgs)*dtp + IF ( ipconc .ge. 2 ) THEN + cx(mgs,lc) = cx(mgs,lc) + & + & dtp*(pccwi(mgs)+pccwd(mgs)) + ENDIF + IF ( ipconc .ge. 3 ) THEN + cx(mgs,lr) = cx(mgs,lr) + & + & dtp*(pcrwi(mgs)+pcrwd(mgs)) + ENDIF + IF ( ipconc .ge. 4 ) THEN + cx(mgs,ls) = cx(mgs,ls) + & + & dtp*(pcswi(mgs)+pcswd(mgs)) + ENDIF + IF ( ipconc .ge. 5 ) THEN + cx(mgs,lh) = cx(mgs,lh) + & + & dtp*(pchwi(mgs)+pchwd(mgs)) + IF ( lhl .gt. 1 ) THEN + cx(mgs,lhl) = cx(mgs,lhl) + & + & dtp*(pchli(mgs)+pchld(mgs)) + + + ENDIF + ENDIF + end do + end if + + + IF ( wrfchem_flag > 0 ) THEN + DO mgs = 1,ngscnt + evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) + rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + & + qraci(mgs) + qsaci(mgs) + qhaci(mgs) + qhlaci(mgs) + qscni(mgs) + ENDDO + ENDIF +! +! +! +! start saturation adjustment +! + if (ndebug .gt. 0 ) write(0,*) 'conc 30a' +! include 'sam.jms.satadj.sgi' +! +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + do mgs = 1,ngscnt + pqs(mgs) = (380.0)/(pres(mgs)) + theta(mgs) = thetap(mgs) + theta0(mgs) + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + end do +! +! melting of cloud ice +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptimlw(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + if( temg(mgs) .gt. tfr .and. & + & qitmp(mgs) .gt. 0.0 ) then + qx(mgs,lc) = qx(mgs,lc) + qitmp(mgs) +! pfrz(mgs) = pfrz(mgs) - qitmp(mgs)*dtpinv + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(- qitmp(mgs)*dtpinv) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) - (felfpi(mgs)*qitmp(mgs)) + ENDIF + pmlt(mgs) = pmlt(mgs) - qitmp(mgs)*dtpinv + scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li) + thetap(mgs) = thetap(mgs) - & + & fcc3(mgs)*qitmp(mgs) + ptimlw(mgs) = -fcc3(mgs)*qitmp(mgs)*dtpinv + cx(mgs,lc) = cx(mgs,lc) + cx(mgs,li) + qx(mgs,li) = 0.0 + cx(mgs,li) = 0.0 + scx(mgs,li) = 0.0 + vx(mgs,li) = 0.0 + qitmp(mgs) = 0.0 + end if + end do + +! +! + + +! do mgs = 1,ngscnt +! qimlw(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv +! end do +! +! homogeneous freezing of cloud water +! + IF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptwfzi(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + +! if( temg(mgs) .lt. tfrh ) THEN +! write(0,*) 'GS: mgs,temp,qc,qi = ',mgs,temg(mgs),temcg(mgs),qx(mgs,lc),qx(mgs,li) +! ENDIF + + ctmp = 0.0 + frac = 0.0 + qtmp = 0.0 + +! if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and. & +! & qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then +! commented for test (12/01/2015): +! if( temg(mgs) .lt. thnuc + 0. .and. & +! & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then + if( ( ( temg(mgs) .lt. thnuc + 0.) .or. (temg(mgs) .lt. thnuc + 2. .and. ibfc >= 3) ) .and. & + & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2)) then + + IF ( ibfc >= 3 ) THEN + frac = Max( 0.25, Min( 1., ((thnuc + 2.) - temg(mgs) )/4.0 ) ) + ELSEIF ( ibfc /= 2 .or. ipconc < 2 ) THEN + frac = Max( 0.25, Min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) ) + ELSE + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 + + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc)) ! number of droplets with volume greater than volt + + qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes + ! sure that cwfrz and qwfrz are consistent and prevents + ! spurious creation of ice crystals. + + ENDIF + qtmp = frac*qx(mgs,lc) + + IF ( ibfc == 4 .and. lis >= 1 ) THEN + qx(mgs,lis) = qx(mgs,lis) + qtmp + ELSE + qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc) + ENDIF + pfrz(mgs) = pfrz(mgs) + qtmp*dtpinv + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(qtmp*dtpinv) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felfpi(mgs)*qtmp + ENDIF + +! IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qx(mgs,lc)/xdn0(li) + IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li) + + IF ( ipconc .ge. 2 ) THEN + ctmp = frac*cx(mgs,lc) +! cx(mgs,li) = cx(mgs,li) + cx(mgs,lc) + IF ( ibfc == 4 .and. lis >= 1 ) THEN + cx(mgs,lis) = cx(mgs,lis) + ctmp + ELSE + cx(mgs,li) = cx(mgs,li) + ctmp + ENDIF + ELSE ! (ipconc .lt. 2 ) + ctmp = 0.0 + IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN + qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1) + +! cx(mgs,lc) = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ELSE + cx(mgs,lc) = Max(0.0,wvel(mgs))*dtp*cwccn & + & /gz(igs(mgs),jgs,kgs(mgs)) + cx(mgs,lc) = cwccn + ENDIF + + IF ( ipconc .ge. 1 ) cx(mgs,li) = Min(ccimx, cx(mgs,li) + cx(mgs,lc)) + ENDIF + + sctmp = frac*scx(mgs,lc) +! scx(mgs,li) = scx(mgs,li) + scx(mgs,lc) + scx(mgs,li) = scx(mgs,li) + sctmp +! thetap(mgs) = thetap(mgs) + fcc3(mgs)*qx(mgs,lc) +! ptwfzi(mgs) = fcc3(mgs)*qx(mgs,lc)*dtpinv +! qx(mgs,lc) = 0.0 +! cx(mgs,lc) = 0.0 +! scx(mgs,lc) = 0.0 + thetap(mgs) = thetap(mgs) + fcc3(mgs)*qtmp + ptwfzi(mgs) = fcc3(mgs)*qtmp*dtpinv + qx(mgs,lc) = qx(mgs,lc) - qtmp + cx(mgs,lc) = cx(mgs,lc) - ctmp + scx(mgs,lc) = scx(mgs,lc) - sctmp + end if + end do + + ENDIF ! warmonly +! +! do mgs = 1,ngscnt +! qwfzi(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv ! Not used?? (ERM) +! end do +! +! reset temporaries for cloud particles and vapor +! + qcond(:) = 0.0 + + IF ( ipconc .le. 1 .and. lwsm6 ) THEN ! Explicit cloud condensation/evaporation (Rutledge and Hobbs 1983) + DO mgs = 1,ngscnt + + qcwtmp(mgs) = qx(mgs,lc) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) +! temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temsav = temg(mgs) +! thsave(mgs) = thetap(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + + IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN + tmp = (qvap(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) ) + qcond(mgs) = Min( Max( 0.0, tmp ), (qvap(mgs)-qvs(mgs)) ) + IF ( qx(mgs,lc) > qxmin(lc) .and. tmp < 0.0 ) THEN ! evaporation + qcond(mgs) = Max( tmp, -qx(mgs,lc) ) + ENDIF + qwvp(mgs) = qwvp(mgs) - qcond(mgs) + qvap(mgs) = qvap(mgs) - qcond(mgs) + qx(mgs,lc) = Max( 0.0, qx(mgs,lc) + qcond(mgs) ) + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs)) + + ENDIF + + ENDDO + + ENDIF + + + IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN +! IF ( ipconc .le. 1 ) THEN + + do mgs = 1,ngscnt + qx(mgs,lv) = max( 0.0, qvap(mgs) ) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qx(mgs,li) = max( 0.0, qx(mgs,li) ) + qitmp(mgs) = qx(mgs,li) + end do +! +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) + temg(mgs) = theta(mgs)*(pinit(kgs(mgs)) + p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap + temsav = temg(mgs) + thsave(mgs) = thetap(mgs) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) +! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN +! C$PAR CRITICAL SECTION +! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs), +! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs), +! : ltemq,igs(mgs),jy,kgs(mgs) +! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt), +! : ab(igs(mgs),jy,kgs(mgs),lt), +! : t0(igs(mgs),jy,kgs(mgs)) +! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs) +! STOP +! C$PAR END CRITICAL SECTION +! END IF + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) +! qss(kz) = qvs(kz) +! if ( temg(kz) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) +! qss(kz) = qis(kz) +! end if +! dont get enough condensation with qcw .le./.gt. qxmin(lc) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if + end do +! +! iterate adjustment +! + do itertd = 1,2 +! + do mgs = 1,ngscnt +! +! calculate super-saturation +! + qitmp(mgs) = qx(mgs,li) + fcci(mgs) = 0.0 + fcip(mgs) = 0.0 + dqcw(mgs) = 0.0 + dqci(mgs) = 0.0 + dqwv(mgs) = ( qx(mgs,lv) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qx(mgs,lc) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qx(mgs,lc) + dqwv(mgs) = dqwv(mgs) + qx(mgs,lc) + end if +! + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit + dqci(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all ice available for sublimation + dqci(mgs) = -qitmp(mgs) + dqwv(mgs) = dqwv(mgs) + qitmp(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor +! +! This next line removed 3/19/2003 thanks to Adam Houston, +! who found the bug in the 3-ICE code +! qwvp(mgs) = max(qwvp(mgs), 0.0) + qitmp(mgs) = qx(mgs,li) + IF ( qitmp(mgs) .ge. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 1.0 + ENDIF + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) + qx(mgs,li) = qx(mgs,li) + dqci(mgs) * fcci(mgs) + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) & + & +(felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN + +! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) +! + qitmp(mgs) = qx(mgs,li) + fracl(mgs) = 1.0 + fraci(mgs) = 0.0 + if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then + fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) + fraci(mgs) = 1.0-fracl(mgs) + end if + if ( temg(mgs) .le. thnuc ) then + fraci(mgs) = 1.0 + fracl(mgs) = 0.0 + end if + fraci(mgs) = 1.0-fracl(mgs) +! + gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & + & / (pi0(mgs)) +! + IF ( temg(mgs) .lt. tfr ) then + IF (qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + END IF + IF ( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbi)**2)) + END IF + IF ( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + cdw = caw*pi0(mgs)*tfrcbw/((temg(mgs)-cbw)**2) + cdi = cai*pi0(mgs)*tfrcbi/((temg(mgs)-cbi)**2) + denom1 = qx(mgs,lc) + qitmp(mgs) + denom2 = 1.0 + gamss* & + & (qx(mgs,lc)*qvs(mgs)*cdw + qitmp(mgs)*qis(mgs)*cdi) / denom1 + dqvcnd(mgs) = dqwv(mgs) / denom2 + END IF + + ENDIF ! temg(mgs) .lt. tfr +! + if ( temg(mgs) .ge. tfr ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + end if +! + delqci1=qx(mgs,li) +! + IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 1.0 + ENDIF +! + dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) + dqci(mgs) = dqvcnd(mgs)*fraci(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & + & / (pi0(mgs)) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (0 & + & +felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) +! IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + qx(mgs,li) = qx(mgs,li) + dqci(mgs)*fcci(mgs) + qitmp(mgs) = qx(mgs,li) +! ENDIF +! +! delqci(mgs) = dqci(mgs)*fcci(mgs) +! + END IF ! dqwv(mgs) .ge. 0. + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + qx(mgs,lv) = max( 0.0, qvap(mgs)) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +!c if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +!c if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if +! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv +! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) + end do +! +! end the saturation adjustment iteration loop +! + end do + + ENDIF ! ( ipconc .le. 1 ) + +! +! spread the growth owing to vapor diffusion onto the +! ice crystal categories using the +! +! END OF SATURATION ADJUSTMENT +! + + if (ndebug .gt. 0 ) write(0,*) 'conc 30b' +! +! +! end of saturation adjustment + +! +! +! !DIR$ IVDEP + do mgs = 1,ngscnt + t0(igs(mgs),jy,kgs(mgs)) = temg(mgs) + end do +! +! Load the save arrays +! + + +! Sample code for using the axtra array to load microphysical rates or quantities for output +! IF ( io_flag .and. nxtra > 1 ) THEN +! DO mgs = 1,ngscnt +! axtra(igs(mgs),jy,kgs(mgs),1) = pfrz(mgs) ! +! axtra(igs(mgs),jy,kgs(mgs),2) = qrcev(mgs) ! pre2 +! axtra(igs(mgs),jy,kgs(mgs),3) = psub(mgs) ! depsubr +! axtra(igs(mgs),jy,kgs(mgs),4) = qrfrz(mgs) ! rain freezing (Bigg) +! axtra(igs(mgs),jy,kgs(mgs),5) = pmlt(mgs) ! melr2 +! ENDDO +! ENDIF + + + + + if (ndebug .gt. 0 ) write(0,*) 'gs 11' + + do mgs = 1,ngscnt +! + an(igs(mgs),jy,kgs(mgs),lt) = & + & theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) + qv0(mgs) ! + + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF +! + + DO il = lc,lhab + IF ( ido(il) .eq. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) + & + & min( an(igs(mgs),jy,kgs(mgs),il), 0.0 ) + qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il) + ENDIF + ENDDO + + IF ( lcina > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lcina) = cina(mgs) + ENDIF + + +! + end do +! + + if ( ipconc .ge. 1 ) then + DO il = lc,lhab !{ + +! write(0,*) 'limiter loop: il,ipc,lz: ',il,ipc(il),lz(il),ipconc + + IF ( ipconc .ge. ipc(il) .and. ido(il) > 0 ) THEN ! { + + IF ( ipconc .ge. 4 .and. ipc(il) .ge. 1 ) THEN ! { + +! write(0,*) 'MY limiter: il,ipc,lz: ',il,ipc(il),lz(il),lr,lzr +! STOP + + IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN ! { { is a two-moment category so dont worry about reflectivity + + + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .le. 0.0 ) THEN + cx(mgs,il) = 0.0 + ELSE !{ + IF ( cx(mgs,il) .gt. cxmin ) THEN !{ +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(cxmin,cx(mgs,il))) + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*cx(mgs,il)) + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,qx,xdn,ln = ',xv(mgs,il),cx(mgs,il),qx(mgs,il),xdn(mgs,il),ln(il) +! ENDIF + + ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also + IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. (il == ls .and. imusnow == 3 ) ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSE + xvbarmax = xvmx(il) + ENDIF + + tmp = 1.0 + IF ( il == ls ) THEN + xvbarmax = xvbarmax*Max(1.,100./Min(100.,xdn(mgs,ls))) + ENDIF + + IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvbarmax ) THEN + xv(mgs,il) = Min( xvbarmax, xv(mgs,il) ) + xv(mgs,il) = Max( xvmn(il), xv(mgs,il) ) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il)) + ENDIF + + ENDIF !} + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,= ',xv(mgs,il),cx(mgs,il) +! ENDIF + + ENDIF !} + ENDDO ! mgs + + + ENDIF ! }} + ENDIF ! } + + DO mgs = 1,ngscnt + IF ( il == lhl ) THEN + ENDIF + an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) + ENDDO + ENDIF ! } + ENDDO ! il } + + IF ( lcin > 1 ) THEN + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lcin) = Max(0.0, ccin(mgs)) + end do + ENDIF + + IF ( ipconc .ge. 2 ) THEN + do mgs = 1,ngscnt + IF ( lss > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lss) = Max(0.0, ssmax(mgs) ) + ENDIF + + IF ( lccn > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + end do + ENDIF + + ELSEIF ( ipconc .eq. 0 .and. lni .gt. 1 ) THEN + + DO mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lni) = Max(cx(mgs,li), 0.0) + ENDDO + + + end if + + IF ( ldovol ) THEN + + DO il = li,lhab + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + + an(igs(mgs),jy,kgs(mgs),lvol(il)) = Max( 0.0, vx(mgs,il) ) + ENDDO + + ENDIF + + ENDDO + + ENDIF +! +! +! +! +! + if (ndebug .gt. 0 ) write(0,*) 'gs 12' + + + + if (ndebug .gt. 0 ) write(0,*) 'gs 13' + + 9998 continue + + if ( kz .gt. nz-1 .and. ix .ge. itile) then + if ( ix .ge. itile ) then + go to 1200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if + + if ( ix .ge. itile ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if + + 1000 continue + 1200 continue +! +! end of gather scatter (for this jy slice) +! +! + + return + end subroutine nssl_2mom_gs +! +!-------------------------------------------------------------------------- +! + + + +! +!-------------------------------------------------------------------------- +! + + +END MODULE module_mp_nssl_2mom diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 new file mode 100644 index 000000000..a965ea849 --- /dev/null +++ b/physics/mp_nsslg.F90 @@ -0,0 +1,704 @@ +!>\file mp_nsslg.F90 +!! This file contains NSSL 2-moment MP scheme. + + +!>\defgroup aansslg NSSL MP Module +!! This module contains the NSSL microphysics scheme. +module mp_nsslg + + use machine, only : kind_phys, kind_real + use module_mp_nssl_2mom, only : nssl_2mom_init, nssl_2mom_driver + + implicit none + + public :: mp_nsslg_init, mp_nsslg_run, mp_nsslg_finalize + + private + logical :: is_initialized = .False. + real :: nssl_qccn + + contains + +!> This subroutine is a wrapper around the nssl_2mom_init(). +!! \section arg_table_mp_nsslg_init Argument Table +!! \htmlinclude mp_nsslg_init.html +!! + subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & + mpicomm, mpirank, mpiroot, & + imp_physics, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & + nssl_cccn, nssl_alphah, nssl_alphahl, nssl_hail_on) + + implicit none + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + + integer, intent(in) :: mpicomm + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + integer, intent(in) :: threads + integer, intent(in) :: imp_physics + integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn + real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl + logical, intent(in) :: nssl_hail_on + + ! Local variables: dimensions used in nssl_init + integer :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real :: nssl_params(20) + integer :: ihailv + + + + errflg = 0 + errmsg = '' + + + if (is_initialized) return + + if (mpirank==mpiroot) then + write(0,*) ' ----------------------------------------------------------------------------------------------------------------' + write(0,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development, use at your own risk --- WARNING ---' + write(0,*) ' ----------------------------------------------------------------------------------------------------------------' + write(6,*) ' ----------------------------------------------------------------------------------------------------------------' + write(6,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development, use at your own risk --- WARNING ---' + write(6,*) ' ----------------------------------------------------------------------------------------------------------------' + end if + +! IF ( kind_phys /= kind_real ) THEN +! errflg = 1 +! write(errmsg,'(a)') 'NSSL MP does not yet work for double precision. Compile for single precision' +! return +! ENDIF + + ! Set internal dimensions + ids = 1 + ims = 1 + its = 1 + ide = ncol + ime = ncol + ite = ncol + jds = 1 + jms = 1 + jts = 1 + jde = 1 + jme = 1 + jte = 1 + kds = 1 + kms = 1 + kts = 1 + kde = nlev + kme = nlev + kte = nlev + + is_initialized = .true. + + nssl_params(:) = 0.0 + nssl_params(1) = nssl_cccn + nssl_params(2) = nssl_alphah + nssl_params(3) = nssl_alphahl + nssl_params(4) = 4.e5 ! nssl_cnoh + nssl_params(5) = 4.e4 ! nssl_cnohl + nssl_params(6) = 4.e5 ! nssl_cnor + nssl_params(7) = 4.e6 ! nssl_cnos + nssl_params(8) = 500. ! nssl_rho_qh + nssl_params(9) = 800. ! nssl_rho_qhl + nssl_params(10) = 100. ! nssl_rho_qs + nssl_params(11) = 0 ! nssl_ipelec_tmp + nssl_params(12) = 11 ! nssl_isaund + nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off + + nssl_qccn = nssl_cccn/1.225 + if (mpirank==mpiroot) then + write(*,*) 'nssl_init: nssl_qccn = ',nssl_qccn + endif + + IF ( nssl_hail_on ) THEN + ihailv = 1 + ELSE + ihailv = -1 + ENDIF + + IF ( imp_physics == imp_physics_nssl2m ) THEN +! write(0,*) 'call nssl_2mom_init' + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) +! write(0,*) 'done nssl_2mom_init' + ELSEIF ( imp_physics == imp_physics_nssl2mccn ) THEN +! write(0,*) 'call nssl_2mom_init ccn' + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) +! write(0,*) 'done nssl_2mom_init ccn' + ELSE +! write(0,*) 'call nssl_2mom_init ccn: imp_physics, imp_physics_nssl2mccn = ',imp_physics, imp_physics_nssl2mccn + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) +! write(0,*) 'done nssl_2mom_init ccn' + ENDIF + + end subroutine mp_nsslg_init + +!>\ingroup aansslg +!>\section gen_nsslg NSSL MP General Algorithm +!>@{ +!> \section arg_table_mp_nsslg_run Argument Table +!! \htmlinclude mp_nsslg_run.html +!! + subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & +! spechum, cccn, qc, qr, qi, qs, qh, qhl, & + spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & + ccw, crw, cci, csw, chw, chl, vh, vhl, & + tgrs, prslk, prsl, phii, omega, dtp, & + prcp, rain, graupel, ice, snow, sr, & + refl_10cm, do_radar_ref, first_time_step, & + re_cloud, re_ice, re_snow, & + imp_physics, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & + nssl_hail_on, nssl_invertccn, ntccn, ntccna, & + errflg, errmsg) + implicit none + integer, intent(in) :: ncol, nlev + real(kind_phys), intent(in ) :: con_g + real(kind_phys), intent(in ) :: con_rd + ! Hydrometeors + real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccn(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccna(1:ncol,1:nlev) + 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) :: qhl(1:ncol,1:nlev) ! hail + 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) :: chl(1:ncol,1:nlev) ! hail number + real(kind_phys), intent(inout) :: vh(1:ncol,1:nlev) ! graupel volume + real(kind_phys), intent(inout) :: vhl(1:ncol,1:nlev) ! hail volume + ! State variables and timestep information + real(kind_phys), intent(inout) :: tgrs(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prsl(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prslk(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: phii(1:ncol,1:nlev+1) + real(kind_phys), intent(in ) :: omega(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: dtp + ! Precip/rain/snow/graupel fall amounts and fraction of frozen precip + real(kind_phys), intent( out) :: prcp(1:ncol) + real(kind_phys), intent( out) :: rain(1:ncol) + real(kind_phys), intent( out) :: graupel(1:ncol) + real(kind_phys), intent( out) :: ice(1:ncol) + real(kind_phys), intent( out) :: snow(1:ncol) + real(kind_phys), intent( out) :: sr(1:ncol) + ! Radar reflectivity + real(kind_phys), intent( out) :: refl_10cm(1:ncol,1:nlev) + logical, intent(in ) :: do_radar_ref, first_time_step + ! Cloud effective radii + real(kind_phys), optional, intent( out) :: re_cloud(1:ncol,1:nlev) + real(kind_phys), optional, intent( out) :: re_ice(1:ncol,1:nlev) + real(kind_phys), optional, intent( out) :: re_snow(1:ncol,1:nlev) + integer, intent(in) :: imp_physics + integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn + logical, intent(in) :: nssl_hail_on, nssl_invertccn + integer, intent(in) :: ntccn, ntccna + + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + + + ! Local variables + + ! Air density + real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 + ! Hydrometeors + real(kind_phys) :: qv_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qc_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qr_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qi_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qs_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qh_mp(1:ncol,1:nlev) !< kg kg-1 (graupel dry mixing ratio) + real(kind_phys) :: qhl_mp(1:ncol,1:nlev) !< kg kg-1 (hail dry mixing ratio) + real(kind_phys) :: cn_mp(1:ncol,1:nlev) + real(kind_phys) :: cna_mp(1:ncol,1:nlev) + ! create temporaries for hail in case it does not exist + real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) + real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + ! Vertical velocity and level width + real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1 + real(kind_phys) :: dz(1:ncol,1:nlev) !< m + + ! Rain/snow/graupel fall amounts + real(kind_phys) :: rain_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: graupel_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: ice_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: snow_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: delta_rain_mp(1:ncol) ! mm + real(kind_phys) :: delta_graupel_mp(1:ncol) ! mm + real(kind_phys) :: delta_ice_mp(1:ncol) ! mm + real(kind_phys) :: delta_snow_mp(1:ncol) ! mm + + real(kind_phys) :: xrain_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xgraupel_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xice_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xsnow_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xdelta_rain_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_graupel_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_ice_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_snow_mp(1:ncol) ! mm + + ! Radar reflectivity + logical :: diagflag ! must be true if do_radar_ref is true, not used otherwise + integer :: do_radar_ref_mp ! integer instead of logical do_radar_ref + ! Effective cloud radii + logical :: do_effective_radii + real(kind_phys) :: re_cloud_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_ice_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_snow_mp(1:ncol,1:nlev) ! m + integer :: has_reqc + integer :: has_reqi + integer :: has_reqs + ! Dimensions used in driver + integer :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, i,j,k + integer :: itimestep = 0 ! timestep counter + integer :: ntmul, n + real, parameter :: dtpmax = 300. ! 600. ! 120. + real(kind_phys) :: dtptmp + integer, parameter :: ndebug = 0 + logical, parameter :: convertdry = .true. + logical :: invertccn + + + + errflg = 0 + errmsg = '' + + IF ( ndebug > 1 ) write(0,*) 'In physics nsslg_run' + + + ! Check initialization state + if (.not.is_initialized) then + write(errmsg, fmt='((a))') 'mp_nssl_run called before mp_nssl_init' + errflg = 1 + return + end if + + invertccn = nssl_invertccn + + !> - Convert specific humidity/moist mixing ratios to dry mixing ratios + qv_mp = spechum/(1.0_kind_phys-spechum) + IF ( convertdry ) THEN + qc_mp = qc/(1.0_kind_phys-spechum) + qr_mp = qr/(1.0_kind_phys-spechum) + qi_mp = qi/(1.0_kind_phys-spechum) + qs_mp = qs/(1.0_kind_phys-spechum) + qh_mp = qh/(1.0_kind_phys-spechum) + IF ( nssl_hail_on ) THEN + qhl_mp = qhl/(1.0_kind_phys-spechum) + ENDIF + ELSE +! qv_mp = spechum ! /(1.0_kind_phys-spechum) + qc_mp = qc ! /(1.0_kind_phys-spechum) + qr_mp = qr ! /(1.0_kind_phys-spechum) + qi_mp = qi ! /(1.0_kind_phys-spechum) + qs_mp = qs ! /(1.0_kind_phys-spechum) + qh_mp = qh ! /(1.0_kind_phys-spechum) + IF ( nssl_hail_on ) THEN + qhl_mp = qhl ! /(1.0_kind_phys-spechum) + ENDIF + + ENDIF + + IF ( nssl_hail_on ) THEN + chl_mp = chl + vhl_mp = vhl + ELSE + qhl_mp = 0 + chl_mp = 0 + vhl_mp = 0 + ENDIF + + + !> - Density of air in kg m-3 + rho = prsl/(con_rd*tgrs) + + !> - Convert omega in Pa s-1 to vertical velocity w in m s-1 + w = -omega/(rho*con_g) + + !> - Layer width in m from geopotential in m2 s-2 + dz = (phii(:,2:nlev+1) - phii(:,1:nlev)) / con_g + + ! Accumulated values inside scheme, not used; + ! only use delta and add to inout variables (different units) + rain_mp = 0 + graupel_mp = 0 + ice_mp = 0 + snow_mp = 0 + delta_rain_mp = 0 + delta_graupel_mp = 0 + delta_ice_mp = 0 + delta_snow_mp = 0 + xrain_mp = 0 + xgraupel_mp = 0 + xice_mp = 0 + xsnow_mp = 0 + xdelta_rain_mp = 0 + xdelta_graupel_mp = 0 + xdelta_ice_mp = 0 + xdelta_snow_mp = 0 + + IF ( ndebug >= 1 ) THEN + write(*,*) 'Max q before micro' + write(*,*) 'qc = ',1000.*maxval(qc_mp) + write(*,*) 'qr = ',1000.*maxval(qr_mp) + write(*,*) 'qi = ',1000.*maxval(qi_mp) + write(*,*) 'qs = ',1000.*maxval(qs_mp) + write(*,*) 'qh = ',1000.*maxval(qh_mp) + IF ( nssl_hail_on ) write(*,*) 'qhl = ',1000.*maxval(qhl_mp) + write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) + ENDIF + + ! Flags for calculating radar reflectivity; diagflag is redundant + if (do_radar_ref) then + diagflag = .true. + do_radar_ref_mp = 1 + else + diagflag = .false. + do_radar_ref_mp = 0 + end if + + if (present(re_cloud) .and. present(re_ice) .and. present(re_snow)) then + do_effective_radii = .true. + has_reqc = 1 + has_reqi = 1 + has_reqs = 1 + else if (.not.present(re_cloud) .and. .not.present(re_ice) .and. .not.present(re_snow)) then + do_effective_radii = .false. + has_reqc = 0 + has_reqi = 0 + has_reqs = 0 + else + write(errmsg,fmt='(*(a))') 'Logic error in mp_nssl_run:', & + ' all or none of the following optional', & + ' arguments are required: re_cloud, re_ice, re_snow' + errflg = 1 + return + end if + ! Initialize to zero, intent(out) variables + re_cloud_mp = 0 + re_ice_mp = 0 + re_snow_mp = 0 + + ! Set internal dimensions + ids = 1 + ims = 1 + its = 1 + ide = ncol + ime = ncol + ite = ncol + jds = 1 + jms = 1 + jts = 1 + jde = 1 + jme = 1 + jte = 1 + kds = 1 + kms = 1 + kts = 1 + kde = nlev + kme = nlev + kte = nlev + + + IF ( ndebug > 1 ) write(0,*) 'call nssl_2mom_driver' + + IF ( dtp > 1.5*dtpmax ) THEN + ntmul = Nint( dtp/dtpmax ) + dtptmp = dtp/ntmul + ELSE + dtptmp = dtp + ntmul = 1 + ENDIF + + IF ( first_time_step ) THEN + itimestep = 2 + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( invertccn ) THEN + cccn = 0 + !cccn = nssl_qccn + ELSE + cccn = nssl_qccn + ENDIF + ENDIF + ELSE + itimestep = 2 + ENDIF + + + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( invertccn ) THEN +! cn_mp = Max(0.0, nssl_qccn - Max(0.0,cccn)) + DO k = 1,nlev + DO i = 1,ncol + cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn(i,k)) ) +! cn_mp(i,k) = Min(nssl_qccn, nssl_qccn - cccn(i,k) ) + ENDDO + ENDDO + ! DO k = 1,nlev + ! DO i = 1,ncol + ! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) + ! cn_mp(i,k) = cccn(i,k) + ! ENDDO + ! ENDDO + ELSE + cn_mp = cccn + ENDIF + IF ( ntccna > 0 ) THEN +! cna_mp = cccna + ELSE + cna_mp = 0 + ENDIF + ENDIF + + + DO n = 1,ntmul + + itimestep = itimestep + 1 + + + + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + + + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & + CCW=ccw, & + CRW=crw, & + CCI=cci, & + CSW=csw, & + CHW=chw, & + CHL=chl_mp, & + VHW=vh, & + VHL=vhl_mp, & + cn=cn_mp, & +! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use + cna=cna_mp, f_cna=.false. , & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & +! icenc=ice_mp, icencv=delta_ice_mp, & + GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & + dbz = refl_10cm, & +! nssl_progn=.false., & + diagflag = diagflag, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + + ELSE + + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & +! CCW=qnc_mp, & + CCW=ccw, & + CRW=crw, & + CCI=cci, & + CSW=csw, & + CHW=chw, & + CHL=chl_mp, & + VHW=vh, & + VHL=vhl_mp, & + ! cn=cccn, & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & +! icenc=ice_mp, icencv=delta_ice_mp, & + GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & + dbz = refl_10cm, & +! nssl_progn=.false., & + diagflag = diagflag, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + ENDIF + + + DO i = 1,ncol + delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) + delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) + delta_ice_mp(i) = delta_ice_mp(i) + xdelta_ice_mp(i) + delta_snow_mp(i) = delta_snow_mp(i) + xdelta_snow_mp(i) + ENDDO + + ENDDO + + + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( invertccn ) THEN + !cccn = Max(0.0, nssl_qccn - cn_mp ) + DO k = 1,nlev + DO i = 1,ncol +! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) + cccn(i,k) = nssl_qccn - cn_mp(i,k) + ENDDO + ENDDO + ELSE + cccn = cn_mp + ENDIF +! cccna = cna_mp + ENDIF + +! test code +! IF ( ntccna > 1 .and. do_effective_radii ) THEN +! cccna = re_ice_mp*1.0E6_kind_phys +! ENDIF + + IF ( ndebug > 1 ) write(0,*) 'done nssl_2mom_driver' + + if (errflg/=0) return + + IF ( ndebug >= 1 ) THEN + write(*,*) 'Max q after micro' + write(*,*) 'qc = ',1000.*maxval(qc_mp) + write(*,*) 'qr = ',1000.*maxval(qr_mp) + write(*,*) 'qi = ',1000.*maxval(qi_mp) + write(*,*) 'qs = ',1000.*maxval(qs_mp) + write(*,*) 'qh = ',1000.*maxval(qh_mp) + IF ( nssl_hail_on ) THEN + write(*,*) 'qhl = ',1000.*maxval(qhl_mp) + ENDIF + write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) + IF ( 1000.*maxval(qc_mp) > 0.5 .or. 1000.*maxval(qi_mp) > 0.09 .or. 1000.*maxval(qs_mp) > 0.1 ) THEN + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' + DO k = 1,nlev + write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, ccw(1,k)*rho(1,k)*1.e-6, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 + ENDDO + ELSE + write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' + DO k = 1,nlev + write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, 0.0, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 + ENDDO + ENDIF + ENDIF + ENDIF + + IF ( nssl_hail_on ) THEN + chl = chl_mp + vhl = vhl_mp + ENDIF + + !> - Convert dry mixing ratios to specific humidity/moist mixing ratios + spechum = qv_mp/(1.0_kind_phys+qv_mp) + IF ( convertdry ) THEN + qc = qc_mp/(1.0_kind_phys+qv_mp) + qr = qr_mp/(1.0_kind_phys+qv_mp) + qi = qi_mp/(1.0_kind_phys+qv_mp) + qs = qs_mp/(1.0_kind_phys+qv_mp) + qh = qh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_hail_on ) THEN + qhl = qhl_mp/(1.0_kind_phys+qv_mp) + ENDIF + ELSE +! spechum = qv_mp ! /(1.0_kind_phys+qv_mp) + qc = qc_mp ! /(1.0_kind_phys+qv_mp) + qr = qr_mp ! /(1.0_kind_phys+qv_mp) + qi = qi_mp ! /(1.0_kind_phys+qv_mp) + qs = qs_mp ! /(1.0_kind_phys+qv_mp) + qh = qh_mp ! /(1.0_kind_phys+qv_mp) + IF ( nssl_hail_on ) THEN + qhl = qhl_mp ! /(1.0_kind_phys+qv_mp) + ENDIF + + ENDIF + +! write(0,*) 'mp_nsslg: done q' + + !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables + ! "rain" in NSSL MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) + + prcp = max(0.0, delta_rain_mp/1000.0_kind_phys) + graupel = max(0.0, delta_graupel_mp/1000.0_kind_phys) + ice = max(0.0, delta_ice_mp/1000.0_kind_phys) + snow = max(0.0, delta_snow_mp/1000.0_kind_phys) + rain = max(0.0, delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp)/1000.0_kind_phys) + +! write(0,*) 'mp_nsslg: done precip' + + if (do_effective_radii) then + ! Convert m to micron + re_cloud = re_cloud_mp*1.0E6_kind_phys + re_ice = re_ice_mp*1.0E6_kind_phys + re_snow = re_snow_mp*1.0E6_kind_phys + end if + + IF ( ndebug > 1 ) write(0,*) 'mp_nsslg: end' + + end subroutine mp_nsslg_run +!>@} + +#if 0 +!! \section arg_table_mp_nsslg_finalize Argument Table +!! \htmlinclude mp_nsslg_finalize.html +!! +#endif + subroutine mp_nsslg_finalize(errflg, errmsg) + implicit none + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + errflg = 0 + errmsg = '' + + + end subroutine mp_nsslg_finalize + +end module mp_nsslg diff --git a/physics/mp_nsslg.meta b/physics/mp_nsslg.meta new file mode 100644 index 000000000..95a11826e --- /dev/null +++ b/physics/mp_nsslg.meta @@ -0,0 +1,578 @@ +[ccpp-table-properties] + name = mp_nsslg + type = scheme + dependencies = machine.F,module_mp_nssl_2mom.F90 + +[ccpp-arg-table] + name = mp_nsslg_init + type = scheme +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[nlev] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[mpicomm] + standard_name = mpi_comm + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in + optional = F +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[threads] + standard_name = omp_threads + long_name = number of OpenMP threads available to scheme + units = count + dimensions = () + type = integer + intent = in + optional = F +[imp_physics] + standard_name = flag_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F +[nssl_cccn] + standard_name = nssl_ccn_concentration + long_name = CCN concentration + units = m-3 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[nssl_alphah] + standard_name = nssl_alpha_graupel + long_name = graupel PSD shape parameter in NSSL micro + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[nssl_alphahl] + standard_name = nssl_alpha_hail + long_name = hail PSD shape parameter in NSSL micro + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = mp_nsslg_run + type = scheme +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[nlev] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[spechum] + standard_name = water_vapor_specific_humidity_updated_by_physics + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qc] + standard_name = cloud_condensed_water_mixing_ratio_updated_by_physics + long_name = cloud water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qr] + standard_name = rain_water_mixing_ratio_updated_by_physics + long_name = rain water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qi] + standard_name = ice_water_mixing_ratio_updated_by_physics + long_name = ice water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qs] + standard_name = snow_water_mixing_ratio_updated_by_physics + long_name = snow water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qh] + standard_name = graupel_mixing_ratio_updated_by_physics + long_name = graupel mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qhl] + standard_name = hail_mixing_ratio_updated_by_physics + long_name = moist (dry+vapor, no condensates) mixing ratio of hail updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cccn] + standard_name = cloud_condensation_nuclei_number_concentration_updated_by_physics + long_name = number concentration of cloud condensation nuclei updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cccna] + standard_name = activated_cloud_condensation_nuclei_number_concentration_updated_by_physics + long_name = number concentration of activated cloud condensation nuclei updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ccw] + standard_name = cloud_droplet_number_concentration_updated_by_physics + long_name = cloud droplet number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[crw] + standard_name = rain_number_concentration_updated_by_physics + long_name = rain number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cci] + standard_name = ice_number_concentration_updated_by_physics + long_name = ice number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[csw] + standard_name = snow_number_concentration_updated_by_physics + long_name = snow number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[chw] + standard_name = graupel_number_concentration_updated_by_physics + long_name = graupel number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[chl] + standard_name = hail_number_concentration_updated_by_physics + long_name = hail number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[vh] + standard_name = graupel_volume_updated_by_physics + long_name = graupel particle volume + units = m3 kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[vhl] + standard_name = hail_volume_updated_by_physics + long_name = hail particle volume + units = m3 kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tgrs] + standard_name = air_temperature_updated_by_physics + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[omega] + standard_name = omega + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[prcp] + standard_name = lwe_thickness_of_explicit_precipitation_amount + long_name = explicit precipitation (rain, ice, snow, graupel) on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rain] + standard_name = lwe_thickness_of_explicit_rain_amount + long_name = explicit rain fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[graupel] + standard_name = lwe_thickness_of_graupel_amount + long_name = graupel fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ice] + standard_name = lwe_thickness_of_ice_amount + long_name = ice fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snow] + standard_name = lwe_thickness_of_snow_amount + long_name = snow fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[sr] + standard_name = ratio_of_snowfall_to_rainfall + long_name = ratio of snowfall to large-scale rainfall + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[refl_10cm] + standard_name = radar_reflectivity_10cm + long_name = instantaneous refl_10cm + units = dBZ + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[do_radar_ref] + standard_name = flag_for_radar_reflectivity + long_name = flag for radar reflectivity + units = flag + dimensions = () + type = logical + intent = in + optional = F +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[re_cloud] + standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle_in_um + long_name = eff. radius of cloud liquid water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = T +[re_ice] + standard_name = effective_radius_of_stratiform_cloud_ice_particle_in_um + long_name = eff. radius of cloud ice water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = T +[re_snow] + standard_name = effective_radius_of_stratiform_cloud_snow_particle_in_um + long_name = effective radius of cloud snow particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = T +[imp_physics] + standard_name = flag_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F +[ntccn] + standard_name = index_for_cloud_condensation_nuclei_number_concentration + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntccna] + standard_name = index_for_activated_cloud_condensation_nuclei_number_concentration + long_name = tracer index for activated cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = mp_nsslg_finalize + 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 + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + From a13afa13d38b8c675cbfa10339fab884669bccc1 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 31 Mar 2021 21:00:16 -0500 Subject: [PATCH 002/217] - Fixes subroutine end statements (causes error on some older compilers) --- physics/h2ointerp.f90 | 4 ++-- physics/ozinterp.f90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/h2ointerp.f90 b/physics/h2ointerp.f90 index fe7acaed3..f26ae6c0c 100644 --- a/physics/h2ointerp.f90 +++ b/physics/h2ointerp.f90 @@ -123,7 +123,7 @@ subroutine setindxh2o(npts,dlat,jindx1,jindx2,ddy) enddo return - end + end subroutine setindxh2o ! !********************************************************************** ! @@ -201,6 +201,6 @@ subroutine h2ointerpol(me,npts,idate,fhour,jindx1,jindx2,h2oplout,ddy) enddo ! return - end + end subroutine h2ointerpol end module h2ointerp diff --git a/physics/ozinterp.f90 b/physics/ozinterp.f90 index acb63efbf..6fe86c8e1 100644 --- a/physics/ozinterp.f90 +++ b/physics/ozinterp.f90 @@ -129,7 +129,7 @@ SUBROUTINE setindxoz(npts,dlat,jindx1,jindx2,ddy) ENDDO RETURN - END + END SUBROUTINE setindxoz ! !********************************************************************** ! @@ -206,6 +206,6 @@ SUBROUTINE ozinterpol(me,npts,IDATE,FHOUR,jindx1,jindx2,ozplout,ddy) enddo ! RETURN - END + END SUBROUTINE ozinterpol end module ozinterp From 8c25e5226cfd50dc5712eb0e0a5385e6cffc39a0 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 1 Apr 2021 15:14:10 -0500 Subject: [PATCH 003/217] Add missing 'nthl' to call interface --- physics/GFS_rrtmg_pre.F90 | 2 +- physics/GFS_rrtmg_pre.meta | 24 ++++++++---------------- 2 files changed, 9 insertions(+), 17 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 029c71637..df9c6e2ed 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,7 +18,7 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, ntwa, ntoz, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & imp_physics_nssl2m, imp_physics_nssl2mccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 5233f0064..db3f928c4 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -185,6 +185,14 @@ type = integer intent = in optional = F +[nthl] + standard_name = index_for_hail + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in + optional = F [ntwa] standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array long_name = tracer index for water friendly aerosol @@ -257,22 +265,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] - standard_name = flag_for_nssl2m_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme From ef29545ad265e6687a111efa66a321cb40daebd7 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 2 Apr 2021 00:14:37 -0500 Subject: [PATCH 004/217] - Pass effrr into NSSL driver - Split NSSL conditional in GFS_rrtmg_pre.F90 from Thompson for now - Text comments in radiation_clouds.f --- physics/GFS_rrtmg_pre.F90 | 39 ++++++++++++++++++++++++++++++++++++-- physics/mp_nsslg.F90 | 4 +++- physics/mp_nsslg.meta | 9 +++++++++ physics/radiation_clouds.f | 7 +++++-- 4 files changed, 54 insertions(+), 5 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index df9c6e2ed..da086a743 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -1032,10 +1032,45 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & effri_inout(:,:), effrs_inout(:,:), & dzb, xlat_d, julian, yearlen, & clouds,cldsa,mtopa,mbota, de_lgth, alpha) ! --- outputs + elseif( imp_physics == imp_physics_nssl2m & + .or. imp_physics == imp_physics_nssl2mccn & + ) then ! Thompson MP + + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + !-- MYNN PBL or convective GF + !-- use cloud fractions with SGS clouds + do k=1,lmk + do i=1,im + clouds(i,k,1) = clouds1(i,k) + enddo + enddo + + ! --- use clduni as with the GFDL microphysics. + ! --- make sure that effr_in=.true. in the input.nml! + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + xlat, xlon, slmsk, dz, delp, IM, LMK, LMP, & + clouds(:,1:LMK,1), & + effrl, effri, effrr, effrs, effr_in , & + dzb, xlat_d, julian, yearlen, & + clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs + + else + ! MYNN PBL or GF convective are not used + call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + xlat,xlon,slmsk,dz,delp, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntsw-1,ntgl-1, & + im, lmk, lmp, uni_cld, lmfshal, lmfdeep2, & + cldcov(:,1:LMK), effrl_inout(:,:), & + effri_inout(:,:), effrs_inout(:,:), & + dzb, xlat_d, julian, yearlen, & + clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs + endif ! MYNN PBL or GF + elseif(imp_physics == imp_physics_thompson & - .or. imp_physics == imp_physics_nssl2m & - .or. imp_physics == imp_physics_nssl2mccn & +! .or. imp_physics == imp_physics_nssl2m & +! .or. imp_physics == imp_physics_nssl2mccn & ) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index a965ea849..66e207568 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -152,7 +152,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & tgrs, prslk, prsl, phii, omega, dtp, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, & - re_cloud, re_ice, re_snow, & + re_cloud, re_ice, re_snow, re_rain, & imp_physics, & imp_physics_nssl2m, imp_physics_nssl2mccn, & nssl_hail_on, nssl_invertccn, ntccn, ntccna, & @@ -200,6 +200,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & real(kind_phys), optional, intent( out) :: re_cloud(1:ncol,1:nlev) real(kind_phys), optional, intent( out) :: re_ice(1:ncol,1:nlev) real(kind_phys), optional, intent( out) :: re_snow(1:ncol,1:nlev) + real(kind_phys), optional, intent( out) :: re_rain(1:ncol,1:nlev) integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn logical, intent(in) :: nssl_hail_on, nssl_invertccn @@ -678,6 +679,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & re_cloud = re_cloud_mp*1.0E6_kind_phys re_ice = re_ice_mp*1.0E6_kind_phys re_snow = re_snow_mp*1.0E6_kind_phys + re_rain = 1.0E3_kind_phys end if IF ( ndebug > 1 ) write(0,*) 'mp_nsslg: end' diff --git a/physics/mp_nsslg.meta b/physics/mp_nsslg.meta index 95a11826e..63786ecd2 100644 --- a/physics/mp_nsslg.meta +++ b/physics/mp_nsslg.meta @@ -480,6 +480,15 @@ kind = kind_phys intent = out optional = T +[re_rain] + standard_name = effective_radius_of_stratiform_cloud_rain_particle_in_um + long_name = effective radius of cloud rain particle in micrometers + units = um + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F [imp_physics] standard_name = flag_for_microphysics_scheme long_name = choice of microphysics scheme diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index dacf6e38e..8c0565eac 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -280,6 +280,7 @@ module module_radiation_clouds !!\n =6: WSM6 microphysics !!\n =10: MG microphysics !!\n =15: Ferrier-Aligo microphysics +!!\n =17/18: NSSL microphysics !!\param me print control flag !>\section gen_cld_init cld_init General Algorithm !! @{ @@ -370,6 +371,8 @@ subroutine cld_init & print *,' --- MG cloud microphysics' elseif (imp_physics == 15) then print *,' --- Ferrier-Aligo cloud microphysics' + elseif (imp_physics == 17 .or. imp_physics == 18) then + print *,' --- NSSL cloud microphysics' else print *,' !!! ERROR in cloud microphysc specification!!!', & & ' imp_physics (NP3D) =',imp_physics @@ -2855,7 +2858,7 @@ end subroutine progcld5 !mz: this is the original progcld5 for Thompson MP (and WSM6), -! to be replaced by the GSL version of progcld6 for Thompson MP +! to be replaced by the GSL version of progcld6 for Thompson MP and NSSL subroutine progcld6 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & @@ -2870,7 +2873,7 @@ subroutine progcld6 & ! ================= subprogram documentation block ================ ! ! ! ! subprogram: progcld6 computes cloud related quantities using ! -! Thompson/WSM6 cloud microphysics scheme. ! +! Thompson/WSM6/NSSL cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! ! condensates, ! From dc2a827178c2b6a8664ab9eaddf7481388429eea Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 2 Apr 2021 10:41:04 -0500 Subject: [PATCH 005/217] Turned off a print statement. --- physics/module_mp_nssl_2mom.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 9b73797c4..93cb1ea5f 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -2103,8 +2103,8 @@ SUBROUTINE nssl_2mom_init( & iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; ENDIF - IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac - IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac +! IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac +! IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac RETURN From 9e30e905427f19da63875d0d483250f97b597a68 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 2 Apr 2021 11:06:50 -0500 Subject: [PATCH 006/217] Restore the incorrectly removed flags. --- physics/GFS_rrtmg_pre.meta | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index db3f928c4..6e2788af7 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -265,6 +265,21 @@ type = integer intent = in optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in- optional = F [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme From 7049163410d7cf362e0a640cb1cd611b5cd5d5b4 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 2 Apr 2021 13:12:49 -0500 Subject: [PATCH 007/217] Turn off setting rain radius for now. --- physics/mp_nsslg.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index 66e207568..3034d9012 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -679,7 +679,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & re_cloud = re_cloud_mp*1.0E6_kind_phys re_ice = re_ice_mp*1.0E6_kind_phys re_snow = re_snow_mp*1.0E6_kind_phys - re_rain = 1.0E3_kind_phys +! re_rain = 1.0E3_kind_phys end if IF ( ndebug > 1 ) write(0,*) 'mp_nsslg: end' From 315489b97f5f21e9e57e00ff1cae3ec1b88492b7 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Tue, 6 Apr 2021 12:07:52 -0500 Subject: [PATCH 008/217] Fixed typo in meta file --- physics/GFS_rrtmg_pre.meta | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 6e2788af7..e44b8b22c 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -279,7 +279,8 @@ units = flag dimensions = () type = integer - intent = in- optional = F + intent = in + optional = F [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme From 2b95bde824f11628bb130deb2cb851608910c2b1 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Tue, 6 Apr 2021 12:16:42 -0500 Subject: [PATCH 009/217] Fixed typo and missing declaration --- physics/GFS_rrtmg_pre.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index da086a743..b695fe767 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -85,7 +85,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv_gf, me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & ntcw, ntiw, ntlnc, ntinc, & - ntrw, ntsw, ntgl, ntwa, ntoz, & + ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & kdt, imp_physics, & From 4b35ce948251656e685848a6142f18136a54a2b6 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 8 Apr 2021 13:31:45 -0500 Subject: [PATCH 010/217] - Fixed setting of itimestep on first model step. This was preventing calcnfromq from running, which creates number concentration from the initial condition hydrometeor mass --- physics/mp_nsslg.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index 3034d9012..7bf7b8233 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -426,7 +426,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ENDIF IF ( first_time_step ) THEN - itimestep = 2 + itimestep = 0 IF ( imp_physics == imp_physics_nssl2mccn ) THEN IF ( invertccn ) THEN cccn = 0 From 1cfe2c89faca9312bdb78cd8a504cc3bbb491c1f Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 9 Apr 2021 10:42:07 -0500 Subject: [PATCH 011/217] Turned on zeroing out of hail for low number concentration. Some spurious points of very small mass with large reflectivity were showing up, perhaps because of the very large time step in UFS (40s). This helps eliminate those. --- physics/module_mp_nssl_2mom.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 93cb1ea5f..7b2dcc6f6 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1410,6 +1410,8 @@ SUBROUTINE nssl_2mom_init( & ENDIF ENDIF + IF ( iresetmoments == 0 ) iresetmoments = lhl + ! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl ! IF ( ipelec > 0 ) idonic = .true. From c27901cb8e369599fb0d7a830937bf36a69b6d1c Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Mon, 12 Apr 2021 09:36:41 -0500 Subject: [PATCH 012/217] Added extra printout info for large fall speeds. --- physics/module_mp_nssl_2mom.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 7b2dcc6f6..29bc4ed31 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -6410,6 +6410,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y + write(0,*) 'q, number, diam1,3(mm) = ', qx(mgs,il),cx(mgs,il),1000.*xdia(mgs,il,1),1000.*xdia(mgs,il,3) ! call commasmpi_abort() ENDIF ! & (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))* & From 21a28759f9d68d1716f38e8d1a7b7cdf2ec98435 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 14 Apr 2021 16:57:34 -0500 Subject: [PATCH 013/217] Call calcnfromq on every time step, which helps keep boundaries a bit cleaner. Changes to calcnfromq to set droplet number as 9 micron radius droplets, and then deplete CCN if turned on. Also set masses to zero if less than qxmin. --- physics/module_mp_nssl_2mom.F90 | 61 +++++++++++++++++++++++++++------ 1 file changed, 50 insertions(+), 11 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 29bc4ed31..1eed6a1d0 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -2702,9 +2702,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! #ifndef CM1 ! for real cases when hydrometeor mixing ratios have been initialized without concentrations - IF ( itimestep == 1 .and. ipconc > 0 ) THEN +! IF ( itimestep == 1 .and. ipconc > 0 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) - ENDIF +! ENDIF ! #endif IF ( present(cu_used) .and. & @@ -4515,6 +4515,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real, parameter :: zsfac = 1./(pi*xdns*xn0s) real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet real xv,xdn integer :: ndbz, nmwgt, nnwgt, nwlessthanz @@ -4548,23 +4549,41 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! Cloud droplets IF ( lnc > 1 ) THEN - IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN - an(ix,jy,kz,lnc) = qccn + IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + + an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)/cwmas09 )*dn(ix,kz) + + IF ( lccn > 1 .and. lccna < 1 ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc) + ENDIF + IF ( lccna > 1 ) THEN + an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) + ENDIF + + ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) ) THEN + + an(ix,jy,kz,lnc) = 0.0 + an(ix,jy,kz,lc) = 0.0 + ENDIF ENDIF ! Cloud ice IF ( lni > 1 ) THEN - IF ( an(ix,jy,kz,lni) <= 0.1*cxmin .and. an(ix,jy,kz,li) > qxmin(li) ) THEN - an(ix,jy,kz,lni) = an(ix,jy,kz,li)/xims + IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin(li) ) THEN + an(ix,jy,kz,lni) = dn(ix,kz)*an(ix,jy,kz,li)/xims + + ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) ) THEN + an(ix,jy,kz,lni) = 0.0 + an(ix,jy,kz,li) = 0.0 ENDIF ENDIF ! rain IF ( lnr > 1 ) THEN - IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin(lr) ) THEN + IF ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) > qxmin(lr) ) THEN q = an(ix,jy,kz,lr) @@ -4576,12 +4595,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio + ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) ) THEN + an(ix,jy,kz,lnr) = 0.0 + an(ix,jy,kz,lr) = 0.0 ENDIF ENDIF ! snow IF ( lns > 1 ) THEN - IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin(ls) ) THEN + IF ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) > qxmin(ls) ) THEN q = an(ix,jy,kz,ls) @@ -4593,13 +4615,16 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio + ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) ) THEN + an(ix,jy,kz,lns) = 0.0 + an(ix,jy,kz,ls) = 0.0 ENDIF ENDIF ! graupel IF ( lnh > 1 ) THEN - IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN + IF ( an(ix,jy,kz,lnh) < cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN IF ( lvh > 1 ) THEN IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh @@ -4614,15 +4639,25 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) nrx = n1*g1h/g0 ! number concentration for different shape parameter - an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio + IF ( nrx > cxmin ) THEN + an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio + ELSE + an(ix,jy,kz,lh) = 0.0 + an(ix,jy,kz,lnh) = 0.0 + an(ix,jy,kz,lvh) = 0.0 + ENDIF + ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) ) THEN + + an(ix,jy,kz,lh) = 0.0 + ENDIF ENDIF ! hail IF ( lnhl > 1 .and. lhl > 1 ) THEN - IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN + IF ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN IF ( lvhl > 1 ) THEN IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl @@ -4639,6 +4674,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio + ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) ) THEN + + an(ix,jy,kz,lhl) = 0.0 + ENDIF ENDIF From 06fc77348d4be13b5f6bd980f5f5fbfefc4d702e Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sun, 18 Apr 2021 20:51:57 -0500 Subject: [PATCH 014/217] Removed re_rain from interface (not used and not planning to use this way) --- physics/mp_nsslg.F90 | 15 ++++++++------- physics/mp_nsslg.meta | 9 --------- 2 files changed, 8 insertions(+), 16 deletions(-) diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index 7bf7b8233..85731baa5 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -95,7 +95,6 @@ subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & kme = nlev kte = nlev - is_initialized = .true. nssl_params(:) = 0.0 nssl_params(1) = nssl_cccn @@ -137,6 +136,8 @@ subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & ! write(0,*) 'done nssl_2mom_init ccn' ENDIF + is_initialized = .true. + end subroutine mp_nsslg_init !>\ingroup aansslg @@ -152,7 +153,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & tgrs, prslk, prsl, phii, omega, dtp, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, & - re_cloud, re_ice, re_snow, re_rain, & + re_cloud, re_ice, re_snow, & imp_physics, & imp_physics_nssl2m, imp_physics_nssl2mccn, & nssl_hail_on, nssl_invertccn, ntccn, ntccna, & @@ -194,13 +195,13 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & real(kind_phys), intent( out) :: snow(1:ncol) real(kind_phys), intent( out) :: sr(1:ncol) ! Radar reflectivity - real(kind_phys), intent( out) :: refl_10cm(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: refl_10cm(1:ncol,1:nlev) logical, intent(in ) :: do_radar_ref, first_time_step ! Cloud effective radii - real(kind_phys), optional, intent( out) :: re_cloud(1:ncol,1:nlev) - real(kind_phys), optional, intent( out) :: re_ice(1:ncol,1:nlev) - real(kind_phys), optional, intent( out) :: re_snow(1:ncol,1:nlev) - real(kind_phys), optional, intent( out) :: re_rain(1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_cloud(1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_ice(1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_snow(1:ncol,1:nlev) +! real(kind_phys), optional, intent( out) :: re_rain(1:ncol,1:nlev) integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn logical, intent(in) :: nssl_hail_on, nssl_invertccn diff --git a/physics/mp_nsslg.meta b/physics/mp_nsslg.meta index 63786ecd2..95a11826e 100644 --- a/physics/mp_nsslg.meta +++ b/physics/mp_nsslg.meta @@ -480,15 +480,6 @@ kind = kind_phys intent = out optional = T -[re_rain] - standard_name = effective_radius_of_stratiform_cloud_rain_particle_in_um - long_name = effective radius of cloud rain particle in micrometers - units = um - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F [imp_physics] standard_name = flag_for_microphysics_scheme long_name = choice of microphysics scheme From 8ff7b02bbd0388dd5dd1e4920989caced82aa8c5 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sun, 18 Apr 2021 20:52:39 -0500 Subject: [PATCH 015/217] Updated calcnfromq to use qxmin_init for higher mass thresholds. Lower mixing ratios masses are transferred to water vapor. Also added second estimate for graupel number conc. and take minimum. Added air density limit in setvtz and nssl_2mom_gs to limit fall speed or rhovt. Added limit on Bigg freezing to only act if freezing radius is 8mm or less. --- physics/module_mp_nssl_2mom.F90 | 461 ++++++++++++-------------------- 1 file changed, 167 insertions(+), 294 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 1eed6a1d0..174cca092 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1,7 +1,7 @@ !WRF:MODEL_LAYER:PHYSICS -! prepocessed on "Oct 16 2020" at "14:58:00" +! prepocessed on "Apr 18 2021" at "20:33:31" @@ -148,7 +148,6 @@ MODULE module_mp_nssl_2mom public nssl_2mom_driver public nssl_2mom_init - public nssl_2mom_init_aero private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis private gamma_dp, gamxinfdp, gamma_dpr private delbk, delabk @@ -221,12 +220,12 @@ MODULE module_mp_nssl_2mom real , private :: auttim = 300. ! 10-ice rain delay time real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual -!#if (NMM_CORE == 1) +#if (NMM_CORE == 1) ! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true -! logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state -!#else + logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state +#else logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state -!#endif +#endif logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) @@ -247,7 +246,7 @@ MODULE module_mp_nssl_2mom ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. - real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) + real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed @@ -270,6 +269,7 @@ MODULE module_mp_nssl_2mom integer, private :: ndebug = -1, ncdebug = 0 integer, private :: ipconc = 5 + integer, private :: inucopt = 0 integer, private :: ichaff = 0 integer, parameter :: ilimit = 0 @@ -296,7 +296,7 @@ MODULE module_mp_nssl_2mom integer, private :: ireadmic = 0 - integer, private :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data + integer, private :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data; =2 for Geoffroy et al. (2010, ACP) integer, private :: iccwflg = 1 ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid) ! (first nucleation is done with a KW sat. adj. step) integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field @@ -769,6 +769,7 @@ MODULE module_mp_nssl_2mom real cno(lc:lqmx) real xvmn(lc:lqmx), xvmx(lc:lqmx) real qxmin(lc:lqmx) + real qxmin_init(lc:lqmx) integer nqsat parameter (nqsat=1000001) ! (nqsat=20001) @@ -816,7 +817,7 @@ MODULE module_mp_nssl_2mom real, parameter :: dhmn0 = 0.3e-3 real, private :: dhmn = dhmn0, dhmx = -1. - real, parameter :: cwradn = 2.5e-7, xcradmn = cwradn ! minimum radius + real, parameter :: cwradn = 2.0e-6, xcradmn = cwradn ! minimum radius real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius real, parameter :: cwc1 = 6.0/(pi*1000.) @@ -1109,182 +1110,6 @@ END FUNCTION fqis -! ##################################################################### -! ArcHyperbolic tangent to handle only positive values of argument - - REAL FUNCTION myatanh(x) - implicit none - real :: x - - IF ( x >= 0.0 .and. x < 1.0 ) THEN - myatanh = 0.5*( Log((x + 1.0)/(1. - x))) ! 0.5*( Log(x + 1.0) - Log(1. - x)) - ELSEIF ( x >= 1.0 ) THEN - myatanh = 1.e32 - ELSE - myatanh = 0 - ENDIF - - END FUNCTION myatanh - -! ##################################################################### -! ##################################################################### - SUBROUTINE nssl_2mom_init_aero(hgt, nwfa2d, nwfa, nifa, qnn2d, qnn, dx, dy, cccn, & - is_start, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte) - -! This subroutine code is mostly borrowed from thompson_init in module_mp_thompson.F -! Here, it is a separate initialization only of things related to aerosols - - IMPLICIT NONE - - INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: hgt - -!..OPTIONAL variables that control application of aerosol-aware scheme - - REAL, DIMENSION(ims:ime,kms:kme,jms:jme), OPTIONAL, INTENT(INOUT) :: qnn,nwfa, nifa - REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL, INTENT(INOUT) :: nwfa2d,qnn2d - REAL, OPTIONAL, INTENT(IN) :: DX, DY, cccn - LOGICAL, OPTIONAL, INTENT(IN) :: is_start - CHARACTER*256:: mp_debug - - - INTEGER:: i, j, k, l, m, n - REAL:: h_01, niIN3, niCCN3, max_test - - REAL, PARAMETER :: eps = 1.E-15 -! LOGICAL:: has_CCN, has_IN - - is_aerosol_aware = .FALSE. -! micro_init = .FALSE. -! has_CCN = .FALSE. -! has_IN = .FALSE. - - - write(mp_debug,*) ' DEBUG checking column of hgt ', its+1,jts+1 - CALL wrf_debug(250, mp_debug) - do k = kts, kte - write(mp_debug,*) ' DEBUGT k, hgt = ', k, hgt(its+1,k,jts+1) - CALL wrf_debug(250, mp_debug) - enddo - - if (PRESENT(qnn2d) .AND. PRESENT(qnn) .AND. PRESENT(nifa)) is_aerosol_aware = .TRUE. - - if (is_aerosol_aware) then - - turn_on_cin = .true. - -!..Check for existing aerosol data, both CCN and IN aerosols. If missing -!.. fill in just a basic vertical profile, somewhat boundary-layer following. - - max_test = MAXVAL ( qnn(its:ite-1,:,jts:jte-1) ) - - if (max_test .lt. eps) then - write(mp_debug,*) ' Apparently there are no initial CCN aerosols, so we will initialize using nssl_cccn value.' - CALL wrf_debug(100, mp_debug) - write(mp_debug,*) ' checked column at point (i,j) = ', its,jts - CALL wrf_debug(100, mp_debug) - do j = jts, min(jde-1,jte) - do i = its, min(ide-1,ite) - do k = 1, kte - qnn(i,k,j) = cccn/1.225 ! naCCN1+naCCN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niCCN3) - enddo - enddo - enddo - else -! has_CCN = .TRUE. - write(mp_debug,*) ' Apparently initial CCN aerosols are present.' - CALL wrf_debug(100, mp_debug) - write(mp_debug,*) ' column sum at point (i,j) = ', its,jts, SUM(qnn(its,:,jts)) - CALL wrf_debug(100, mp_debug) - endif - - - max_test = MAXVAL ( nifa(its:ite-1,:,jts:jte-1) ) - - if (max_test .lt. eps) then - write(mp_debug,*) ' Apparently there are no initial IN aerosols.' - CALL wrf_debug(100, mp_debug) - write(mp_debug,*) ' checked column at point (i,j) = ', its,jts - CALL wrf_debug(100, mp_debug) - do j = jts, min(jde-1,jte) - do i = its, min(ide-1,ite) - if (hgt(i,1,j).le.1000.0) then - h_01 = 0.8 - elseif (hgt(i,1,j).ge.2500.0) then - h_01 = 0.01 - else - h_01 = 0.8*cos(hgt(i,1,j)*0.001 - 1.0) - endif - niIN3 = -1.0*ALOG(naIN1/naIN0)/h_01 - nifa(i,1,j) = naIN1+naIN0*exp(-((hgt(i,2,j)-hgt(i,1,j))/1000.)*niIN3) - do k = 2, kte - nifa(i,k,j) = naIN1+naIN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niIN3) - enddo - enddo - enddo - else -! has_IN = .TRUE. - write(mp_debug,*) ' Apparently initial IN aerosols are present.' - CALL wrf_debug(100, mp_debug) - write(mp_debug,*) ' column sum at point (i,j) = ', its,jts, SUM(nifa(its,:,jts)) - CALL wrf_debug(100, mp_debug) - endif - -!..Capture initial state lowest level CCN aerosol data in 2D array. - -! do j = jts, min(jde-1,jte) -! do i = its, min(ide-1,ite) -! qnn2d(i,j) = qnn(i,kts,j) -! enddo -! enddo - -!..Scale the lowest level aerosol data into an emissions rate. This is -!.. very far from ideal, but need higher emissions where larger amount -!.. of existing and lesser emissions where not already lots of aerosols -!.. for first-order simplistic approach. Later, proper connection to -!.. emission inventory would be better, but, for now, scale like this: -!.. where: Nwfa=50 per cc, emit 0.875E4 aerosols per kg per second -!.. Nwfa=500 per cc, emit 0.875E5 aerosols per kg per second -!.. Nwfa=5000 per cc, emit 0.875E6 aerosols per kg per second -!.. for a grid with 20km spacing and scale accordingly for other spacings. - - if (is_start) then - if (SQRT(DX*DY)/20000.0 .ge. 1.0) then - h_01 = 0.875 - else - h_01 = (0.875 + 0.125*((20000.-SQRT(DX*DY))/16000.)) * SQRT(DX*DY)/20000. - endif - write(mp_debug,*) ' aerosol surface flux emission scale factor is: ', h_01 - CALL wrf_debug(100, mp_debug) - do j = jts, min(jde-1,jte) - do i = its, min(ide-1,ite) - ! qnn2d(i,j) = 10.0**(LOG10(qnn(i,kts,j)*1.E-6)-3.69897) - ! qnn2d(i,j) = qnn2d(i,j)*h_01 * 1.E6 - qnn2d(i,j) = (qnn(i,kts,j))/5000. ! same as above -- scale to 5000s for full restore - qnn2d(i,j) = qnn2d(i,j)*h_01 - - nwfa2d(i,j) = 10.0**(LOG10(nwfa(i,kts,j)*1.E-6)-3.69897) - nwfa2d(i,j) = nwfa2d(i,j)*h_01 * 1.E6 - - enddo - enddo -! else -! write(mp_debug,*) ' sample (lower-left) aerosol surface flux emission rate: ', qnn2d(1,1) -! CALL wrf_debug(100, mp_debug) - endif - - endif - - - - RETURN -END SUBROUTINE nssl_2mom_init_aero - ! ##################################################################### ! ##################################################################### @@ -1301,7 +1126,6 @@ SUBROUTINE nssl_2mom_init( & & nssl_snowfallfac & ) - implicit none real, intent(in), optional :: & @@ -1332,12 +1156,12 @@ SUBROUTINE nssl_2mom_init( & real :: alp,ratio double precision :: x,y,y2,y7 - logical :: turn_on_ccna + logical :: turn_on_ccna, turn_on_cina integer :: istat turn_on_ccna = .false. -! turn_on_cin = .false. + turn_on_cina = .false. ! ! set some global values from namelist input ! @@ -1409,9 +1233,8 @@ SUBROUTINE nssl_2mom_init( & ! idoci = 0 ! try this later ENDIF ENDIF - - IF ( iresetmoments == 0 ) iresetmoments = lhl - + + IF ( iresetmoments == 0 ) iresetmoments = 1 ! lhl ! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl ! IF ( ipelec > 0 ) idonic = .true. @@ -1702,6 +1525,12 @@ SUBROUTINE nssl_2mom_init( & denscale(ltmp) = 1 ENDIF + IF ( turn_on_cina ) THEN + ltmp = ltmp + 1 + lcina = ltmp + denscale(ltmp) = 1 + ENDIF + IF ( turn_on_cin .or. is_aerosol_aware ) THEN ltmp = ltmp + 1 lcin = ltmp @@ -2025,6 +1854,7 @@ SUBROUTINE nssl_2mom_init( & IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12 IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12 + qxmin_init(:) = 1.0e-8 ! threshold for considering single-moment initial condition mixing ratios ! constants for droplet nucleation cckm = cck-1. @@ -2116,7 +1946,7 @@ END SUBROUTINE nssl_2mom_init ! ##################################################################### SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & - cn, vhw, vhl, cna, f_cn, f_cna, & + cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & zrw, zhw, zhl, & qsw, qhw, qhlw, & tt, th, pii, p, w, dn, dz, dtp, itimestep, & @@ -2193,7 +2023,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw zrw, zhw, zhl, & qsw, qhw, qhlw, & qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) @@ -2241,7 +2071,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, optional, intent(in) :: dx,dy real, intent(in):: dtp integer, intent(in):: itimestep !, ccntype - logical, optional, intent(in) :: diagflag, f_cna, f_cn + logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina integer, optional, intent(in) :: ipelectmp, ke_diag LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem @@ -2308,7 +2138,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed double precision :: timevtcalc,timesetvt - logical :: f_cnatmp + logical :: f_cnatmp, f_cinatmp integer :: kediagloc integer :: iunit @@ -2348,6 +2178,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSE f_cnatmp = .false. ENDIF + + IF ( present( f_cina ) ) THEN + f_cinatmp = f_cina + ELSE + f_cinatmp = .false. + ENDIF IF ( present( vzf ) ) vzflag0 = 1 @@ -2383,45 +2219,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw renucfrac = 1.0 ENDIF -! set up CCN array and some other static local values - IF ( .false. ) THEN - IF ( itimestep == 1 .and. .not. invertccn .and. present( cn ) ) THEN - ! this is not needed for WRF 3.8 and later because it is done in physics_init, - ! but kept for backwards compatibility with earlier versions - IF ( cn((ite+its)/2,(kte+kts)/2,(jte+jts)/2) < 10.0 ) THEN ! initialize ccn if not already done - DO jy = jts,jte - DO kz = kts,kte - DO ix = its,ite - cn(ix,kz,jy) = qccn - ENDDO - ENDDO - ENDDO - ENDIF - ENDIF - - IF ( itimestep == 1 .and. invertccn .and. present( cn ) ) THEN - ! this is not needed for WRF 3.8 and later because it is done in physics_init, - ! but kept for backwards compatibility with earlier versions - DO jy = jts,jte - DO kz = kts,kte - DO ix = its,ite - cn(ix,kz,jy) = 0.0 - ENDDO - ENDDO - ENDDO - ENDIF - - IF ( invertccn .and. present( cn ) ) THEN ! hack for WRF to convert activated ccn to unactivated, then do not have to - ! worry about initial and boundary conditions - they are zero - DO jy = jts,jte - DO kz = kts,kte - DO ix = its,ite - ! cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) - ENDDO - ENDDO - ENDDO - ENDIF - ENDIF ! ENDIF ! itimestep == 1 @@ -2512,11 +2309,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( is_aerosol_aware .and. flag_qnwfa ) THEN an(ix,1,kz,lccn) = nwfa(ix,kz,jy) ELSEIF ( present( cn ) ) THEN - IF ( invertccn ) THEN - an(ix,1,kz,lccn) = qccn - cn(ix,kz,jy) - ELSE - an(ix,1,kz,lccn) = cn(ix,kz,jy) - ENDIF + IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN + an(ix,1,kz,lccna) = cn(ix,kz,jy) + an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = cn(ix,kz,jy) + ENDIF ELSE IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) @@ -2532,6 +2330,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw an(ix,1,kz,lccna) = cna(ix,kz,jy) ENDIF ENDIF + + IF ( lcina > 1 ) THEN + IF ( present( cni ) .and. f_cinatmp ) THEN + an(ix,1,kz,lcina) = cni(ix,kz,jy) + ENDIF + ENDIF IF ( lcin > 1 .and. flag_qnifa ) THEN an(ix,1,kz,lcin) = nifa(ix,kz,jy) @@ -2702,9 +2506,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! #ifndef CM1 ! for real cases when hydrometeor mixing ratios have been initialized without concentrations -! IF ( itimestep == 1 .and. ipconc > 0 ) THEN + IF ( itimestep == 1 .and. ipconc > 0 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) -! ENDIF + ENDIF ! #endif IF ( present(cu_used) .and. & @@ -2960,15 +2764,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! nwfa(ix,kz,jy) = Min(1.5e9, nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp) IF ( kz == 1 ) nwfa(ix,kz,jy) = nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN - IF ( invertccn ) THEN - cn(ix,kz,jy) = qccn - an(ix,1,kz,lccn) + IF ( lccna > 1 .and. .not. present( cna ) ) THEN + cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) ELSE cn(ix,kz,jy) = an(ix,1,kz,lccn) ENDIF ENDIF IF ( lccna > 1 ) THEN IF ( present( cna ) .and. f_cnatmp ) THEN - cna(ix,kz,jy) = an(ix,1,kz,lccna) + cna(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) + ENDIF + ENDIF + + IF ( lcina > 1 ) THEN + IF ( present( cni ) .and. f_cinatmp ) THEN + cni(ix,kz,jy) = Max(0.0, an(ix,1,kz,lcina) ) ENDIF ENDIF @@ -3003,15 +2813,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! jy - IF ( invertccn .and. present( cn ) ) THEN ! hack to convert unactivated ccn back to activated - DO jy = jts,jte - DO kz = kts,kte - DO ix = its,ite -! cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) - ENDDO - ENDDO - ENDDO - ENDIF @@ -3764,7 +3565,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO ix = ixb,ixe db1(ix,kz) = dn(ix,jy,kz) db1inv(ix,kz) = 1./dn(ix,jy,kz) - rhovtzx(kz,ix) = Sqrt(rho00*db1inv(ix,kz) ) + rhovtzx(kz,ix) = Sqrt(rho00*Min(1.0/0.05, db1inv(ix,kz))) ! prevent excessive rhovt ENDDO ENDDO @@ -4505,9 +4306,9 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) integer ix,jy,kz - double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv - real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4 + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) real, parameter :: zhfac = 1./(pi*xdnh*xn0h) @@ -4515,6 +4316,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real, parameter :: zsfac = 1./(pi*xdns*xn0s) real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx) real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet real xv,xdn @@ -4549,7 +4351,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! Cloud droplets IF ( lnc > 1 ) THEN - IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)/cwmas09 )*dn(ix,kz) @@ -4560,8 +4362,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) ENDIF - ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) ) THEN + ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. & + ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) an(ix,jy,kz,lnc) = 0.0 an(ix,jy,kz,lc) = 0.0 @@ -4571,10 +4375,12 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! Cloud ice IF ( lni > 1 ) THEN - IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin(li) ) THEN + IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin_init(li) ) THEN an(ix,jy,kz,lni) = dn(ix,kz)*an(ix,jy,kz,li)/xims - ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) ) THEN + ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) .or. & + ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) <= qxmin_init(li)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) an(ix,jy,kz,lni) = 0.0 an(ix,jy,kz,li) = 0.0 ENDIF @@ -4583,7 +4389,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! rain IF ( lnr > 1 ) THEN - IF ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) > qxmin(lr) ) THEN + IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin_init(lr) ) THEN q = an(ix,jy,kz,lr) @@ -4595,7 +4401,9 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio - ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) ) THEN + ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) .or. & + ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) <= qxmin_init(lr)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) an(ix,jy,kz,lnr) = 0.0 an(ix,jy,kz,lr) = 0.0 ENDIF @@ -4603,7 +4411,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! snow IF ( lns > 1 ) THEN - IF ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) > qxmin(ls) ) THEN + IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN q = an(ix,jy,kz,ls) @@ -4614,17 +4422,20 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) nrx = n1*g1s/g0 ! number concentration for different shape parameter an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio - - ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) ) THEN + + ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) .or. & + ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) <= qxmin_init(ls)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) an(ix,jy,kz,lns) = 0.0 an(ix,jy,kz,ls) = 0.0 + ENDIF ENDIF ! graupel IF ( lnh > 1 ) THEN - IF ( an(ix,jy,kz,lnh) < cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN + IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin_init(lh) ) THEN IF ( lvh > 1 ) THEN IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh @@ -4639,6 +4450,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) nrx = n1*g1h/g0 ! number concentration for different shape parameter + nrx2 = dn(ix,kz) * q / xgms + + nrx = Min( nrx, nrx2 ) + IF ( nrx > cxmin ) THEN an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio ELSE @@ -4647,8 +4462,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lvh) = 0.0 ENDIF - ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) ) THEN + ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) .or. & + ( an(ix,jy,kz,lnh) <= cxmin .and. an(ix,jy,kz,lh) <= qxmin_init(lh)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) an(ix,jy,kz,lh) = 0.0 ENDIF @@ -4657,7 +4474,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! hail IF ( lnhl > 1 .and. lhl > 1 ) THEN - IF ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN + IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin_init(lhl) ) THEN IF ( lvhl > 1 ) THEN IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl @@ -4674,8 +4491,11 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio - ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) ) THEN + + ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. & + ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) an(ix,jy,kz,lhl) = 0.0 ENDIF @@ -6388,7 +6208,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! { vtxbar(mgs,il,2) = & & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & - & (3.0*cd*rho0(mgs)) ) + & (3.0*cd*Max(0.05,rho0(mgs))) ) ELSE IF ( il == lh .and. icdx /= 6 ) bbx = bx(il) @@ -6492,7 +6312,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSE ! not lh or lhl vtxbar(mgs,il,2) = & & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & - & (3.0*cdx(il)*rho0(mgs)) ) + & (3.0*cdx(il)*Max(0.05,rho0(mgs))) ) vtxbar(mgs,il,3) = vtxbar(mgs,il,1) if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5' @@ -8076,6 +7896,7 @@ SUBROUTINE NUCOND & implicit none +! real :: cwmasn = 1000.*0.523599*(2.*2.e-6)**3 integer :: nx,ny,nz,na,nxi integer :: nor,norz, jyslab ! ,nht,ngt,igsr real :: dtp ! time step @@ -9631,6 +9452,9 @@ SUBROUTINE NUCOND & xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx ) xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn ) cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) +! IF ( cx(mgs,lc) > tmp*1.1 ) THEN +! write(0,*) 'nucond: kgs, ccw1,2 = ',kgs(mgs),tmp,cx(mgs,lc) +! ENDIF ENDIF ENDIF @@ -10448,19 +10272,15 @@ subroutine nssl_2mom_gs & real bfnu, bfnu0, bfnu1 parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0) ) real ventr, ventc - real volb, aa1, aa2 + real volb double precision t2s, xdp double precision xl2p(ngs),rb(ngs) - parameter ( aa1 = 9.44e15, aa2 = 5.78e3 ) ! a1 in Ziegler + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler ! snow parameters: - real cexs, cecs - parameter ( cexs = 0.1, cecs = 0.5 ) - real rvt ! ratio of collection kernels (Zrnic et al, 1993) - parameter ( rvt = 0.104 ) - real kfrag ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) - parameter ( kfrag = 1.0e-6 ) - real mfrag ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) - parameter ( mfrag = 1.0e-10) + real, parameter :: cexs = 0.1, cecs = 0.5 + real, parameter :: rvt = 0.104 ! ratio of collection kernels (Zrnic et al, 1993) + real, parameter :: kfrag = 1.0e-6 ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) + real, parameter :: mfrag = 1.0e-10 ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) double precision cautn(ngs), rh(ngs), nh(ngs) real ex1, ft, rhoinv(ngs) double precision ec0(ngs) @@ -11587,7 +11407,7 @@ subroutine nssl_2mom_gs & pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) rhoinv(mgs) = 1.0/rho0(mgs) - rhovt(mgs) = Sqrt(rho00/rho0(mgs)) + rhovt(mgs) = Sqrt(rho00/Max(0.05,rho0(mgs))) ! prevent excessive rhovt pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs)) @@ -11713,6 +11533,10 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + IF ( qx(mgs,li) .le. qxmin(li) ) THEN + cx(mgs,li) = 0.0 + ENDIF + IF ( lcina .gt. 1 ) THEN cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) ELSE @@ -11727,6 +11551,9 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) ! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + IF ( qx(mgs,lc) .le. qxmin(lc) ) THEN + cx(mgs,lc) = 0.0 + ENDIF IF ( lss > 1 ) THEN ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) ENDIF @@ -13839,8 +13666,23 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt csacs(mgs) = 0.0 IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 ) THEN ! .and. xv(mgs,ls) < 0.25*xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN - csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density - csacs(mgs) = min(csacs(mgs),csmxd(mgs)) + + IF ( iessec0flag == 0 ) THEN + ec0(mgs) = 1.0 + ELSE + tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass + IF ( tmp .lt. essfrac1 ) THEN + ec0(mgs) = 1.0 + ELSEIF ( tmp .gt. essfrac2 ) THEN + ec0(mgs) = 0.0 + ELSE + ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1) + ENDIF + ENDIF + + csacs(mgs) = ec0(mgs)*rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*essrmax**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density + csacs(mgs) = Min(csacs(mgs),csmxd(mgs)) ENDIF end do end if @@ -14441,12 +14283,13 @@ subroutine nssl_2mom_gs & IF ( ibiggopt == 2 .and. imurain == 1 ) THEN ! ! integrate from Bigg diameter (for given supercooling Ts) to infinity - volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 (Proc. Phys. Soc. London) ! for mean temperature for freezing: -ln (V) = a*Ts - b, where a = 6.9/6.8, or approx a = 1.0, and b = 16.2 ! volt is given in cm**3, so convert to m**3 dbigg = (6./pi* volt )**(1./3.) ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. + IF ( dbigg < 8.e-3 ) THEN !{ only bother if freezing diameter is reasonable ratio = Min(maxratiolu, dbigg/xdia(mgs,lr,1) ) @@ -14477,7 +14320,15 @@ subroutine nssl_2mom_gs & qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv qrfrzf(mgs) = qrfrz(mgs) + + IF ( qrfrz(mgs)*dtp < qxmin(lh) .or. crfrz(mgs)*dtp < cxmin ) THEN + crfrz(mgs) = 0.0 + qrfrz(mgs) = 0.0 + + ELSE !{ + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) @@ -14497,7 +14348,6 @@ subroutine nssl_2mom_gs & crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 - ELSE !{ ! recalculate using dhmn for ratio @@ -14543,6 +14393,8 @@ subroutine nssl_2mom_gs & qrfrzs(mgs) = 0.0 ENDIF ! } + ENDIF !} + IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) qrfrz(mgs) = fac*qrfrz(mgs) @@ -14552,6 +14404,9 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = fac*crfrzs(mgs) crfrzf(mgs) = fac*crfrzf(mgs) ENDIF + + ENDIF !} + ! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN ! fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr) ! crfrz(mgs) = fac*crfrz(mgs) @@ -16629,20 +16484,33 @@ subroutine nssl_2mom_gs & ELSEIF ( ihlcnh == 3 ) THEN !{ IF ( wtest .and. & - ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) ) THEN + ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN ! convert number, mass, and reflectivity for d > dw + IF ( ipconc == 5 ) THEN + dg0(mgs) = Min( dg0(mgs), hldia1 ) + !dg0(mgs) = hldia1 + ENDIF + ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) ! mass tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + IF ( ipconc == 5 ) THEN + ! tmp2 = Min( 0.25, tmp2 ) + ENDIF qxd1 = qx(mgs,lh)*(tmp2) qhlcnh(mgs) = dtpinv*qxd1 - IF ( qxd1 > qxmin(lhl) ) THEN + + + IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN ! number tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + IF ( ipconc == 5 ) THEN + ! tmp = Min( 0.2, tmp ) + ENDIF cxd1 = cx(mgs,lh)*( tmp) chlcnh(mgs) = dtpinv*cxd1 chlcnhhl(mgs) = chlcnh(mgs) @@ -19561,13 +19429,17 @@ subroutine nssl_2mom_gs & ! Sample code for using the axtra array to load microphysical rates or quantities for output +! +! Note that indices 1 and 2 are used in the nucond subroutine for condensation/evap of droplets (1) and +! condensation of rain (2) +! ! IF ( io_flag .and. nxtra > 1 ) THEN ! DO mgs = 1,ngscnt -! axtra(igs(mgs),jy,kgs(mgs),1) = pfrz(mgs) ! -! axtra(igs(mgs),jy,kgs(mgs),2) = qrcev(mgs) ! pre2 -! axtra(igs(mgs),jy,kgs(mgs),3) = psub(mgs) ! depsubr -! axtra(igs(mgs),jy,kgs(mgs),4) = qrfrz(mgs) ! rain freezing (Bigg) -! axtra(igs(mgs),jy,kgs(mgs),5) = pmlt(mgs) ! melr2 +! axtra(igs(mgs),jy,kgs(mgs),3) = pfrz(mgs) ! +! axtra(igs(mgs),jy,kgs(mgs),4) = qrcev(mgs) ! pre2 +! axtra(igs(mgs),jy,kgs(mgs),5) = psub(mgs) ! depsubr +! axtra(igs(mgs),jy,kgs(mgs),6) = qrfrz(mgs) ! rain freezing (Bigg) +! axtra(igs(mgs),jy,kgs(mgs),7) = pmlt(mgs) ! melr2 ! ENDDO ! ENDIF @@ -19633,7 +19505,8 @@ subroutine nssl_2mom_gs & ! ENDIF ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also - IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. (il == ls .and. imusnow == 3 ) ) THEN + IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. & + & (il == ls .and. imusnow == 3 ) ) THEN xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) From 6d484f7c8615193a90ce51172ac4988dc3998a9e Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 29 Apr 2021 11:34:57 -0500 Subject: [PATCH 016/217] Changed itimestep to a purely local variable (i.e., not saved) --- physics/mp_nsslg.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index 85731baa5..316b0c399 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -266,7 +266,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, i,j,k - integer :: itimestep = 0 ! timestep counter + integer :: itimestep ! timestep counter integer :: ntmul, n real, parameter :: dtpmax = 300. ! 600. ! 120. real(kind_phys) :: dtptmp From 635e028f3c7afd48f94fb1bd76325b4679ec6333 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sun, 9 May 2021 18:27:31 -0500 Subject: [PATCH 017/217] Fixed bug in setting array values of "rain" (noticed by E. Aligo) --- physics/mp_nsslg.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index 316b0c399..a2dc50cce 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -671,7 +671,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & graupel = max(0.0, delta_graupel_mp/1000.0_kind_phys) ice = max(0.0, delta_ice_mp/1000.0_kind_phys) snow = max(0.0, delta_snow_mp/1000.0_kind_phys) - rain = max(0.0, delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp)/1000.0_kind_phys) + rain = max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) ! write(0,*) 'mp_nsslg: done precip' From 9d0fcbd11af6c47ba231175fca117c1e5a5a67a0 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 30 Sep 2021 19:46:52 -0500 Subject: [PATCH 018/217] - Changed from two imp_physics_nssl flags to a single one with second flag for nssl_ccn_on - Updataed microphysics - Radiation (rrtmg) includes calculated rain radius. Test code to compute radii in the subroutine, but something not right with incoming number concentrations - Renamed mp_nsslg to mp_nssl --- physics/GFS_MP_generic.F90 | 12 +- physics/GFS_MP_generic.meta | 10 +- physics/GFS_PBL_generic.F90 | 44 +- physics/GFS_PBL_generic.meta | 36 +- physics/GFS_rrtmg_pre.F90 | 158 ++- physics/GFS_rrtmg_pre.meta | 66 +- physics/GFS_suite_interstitial.F90 | 19 +- physics/GFS_suite_interstitial.meta | 22 +- physics/maximum_hourly_diagnostics.F90 | 11 +- physics/maximum_hourly_diagnostics.meta | 10 +- physics/module_MYNNPBL_wrapper.F90 | 33 +- physics/module_MYNNPBL_wrapper.meta | 30 +- physics/module_mp_nssl_2mom.F90 | 1271 +++++++++++++++-------- physics/{mp_nsslg.F90 => mp_nssl.F90} | 498 ++++++--- physics/{mp_nsslg.meta => mp_nssl.meta} | 304 +++++- 15 files changed, 1805 insertions(+), 719 deletions(-) rename physics/{mp_nsslg.F90 => mp_nssl.F90} (58%) rename physics/{mp_nsslg.meta => mp_nssl.meta} (69%) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 588891b25..8d5e92265 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -85,8 +85,7 @@ end subroutine GFS_MP_generic_post_init !> \section gfs_mp_gen GFS MP Generic Post General Algorithm !> @{ subroutine GFS_MP_generic_post_run( & - im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & + 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, con_g, rainmin, dtf, frain, rainc, & rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, 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, & @@ -102,7 +101,7 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires - integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn + integer, intent(in) :: imp_physics_nssl logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm integer, intent(in) :: index_of_temperature,index_of_process_mp @@ -185,8 +184,7 @@ subroutine GFS_MP_generic_post_run( ice = ice0 snow = snow0 ! Do it right from the beginning for Thompson - else if (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl2m & - .or. imp_physics == imp_physics_nssl2mccn) then + else if (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl ) then tprcp = max (zero, rainc + frain * rain1) ! time-step convective and explicit precip graupel = frain*graupel0 ! time-step graupel ice = frain*ice0 ! time-step ice @@ -225,7 +223,7 @@ subroutine GFS_MP_generic_post_run( ! ! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation - if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson) then + if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson .and. imp_physics /= imp_physics_nssl) then do i=1,im tprcp(i) = max(zero, rain(i) ) if(doms(i) > zero .or. domip(i) > zero) then @@ -267,7 +265,7 @@ subroutine GFS_MP_generic_post_run( !! \f$0^oC\f$. if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. & - imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn) then + imp_physics == imp_physics_nssl ) then ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index 372cdf98c..18e399b43 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -240,7 +240,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -248,14 +248,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [cal_pre] standard_name = flag_for_dominant_precipitation_type_partition long_name = flag controls precip type algorithm diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 52f8cb63e..28333fc2e 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -14,15 +14,16 @@ module GFS_PBL_generic_common subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & imp_physics_thompson, ltaerosol, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, kk, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & errmsg, errflg) implicit none ! integer, intent(in ) :: imp_physics, imp_physics_wsm6, & imp_physics_thompson, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr - logical, intent(in ) :: ltaerosol + imp_physics_zhao_carr,imp_physics_nssl + logical, intent(in ) :: ltaerosol, nssl_hail_on, nssl_ccn_on integer, intent(out) :: kk character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -53,6 +54,13 @@ subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & elseif (imp_physics == imp_physics_zhao_carr) then ! Zhao/Carr/Sundqvist kk = 3 + elseif (imp_physics == imp_physics_nssl) then + IF ( nssl_hail_on ) THEN + kk = 16 + ELSE + kk = 13 + ENDIF + IF ( nssl_ccn_on ) kk = kk + 1 else write(errmsg,'(*(a))') 'Logic error: unknown microphysics option in set_aerosol_tracer_index' kk = -999 @@ -84,8 +92,8 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & ntccn, nthl, nthnc, ntgv, nthv, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, ltaerosol, & - imp_physics_nssl2m,imp_physics_nssl2mccn, ltaerosol, nssl_hail_on, & + imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, imp_physics_nssl, & + ltaerosol, nssl_ccn_on, nssl_hail_on, & hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) @@ -104,8 +112,8 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend - integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn - logical, intent(in) :: cplchm, ltaerosol, nssl_hail_on + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: cplchm, ltaerosol, nssl_hail_on, nssl_ccn_on real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs @@ -255,7 +263,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, enddo enddo rtg_ozone_index = 3 - elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + elseif (imp_physics == imp_physics_nssl ) then ! nssl IF ( nssl_hail_on ) THEN do k=1,levs @@ -276,7 +284,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, vdftra(i,k,14) = qgrs(i,k,ntgv) vdftra(i,k,15) = qgrs(i,k,nthv) vdftra(i,k,16) = qgrs(i,k,ntoz) - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN vdftra(i,k,17) = qgrs(i,k,ntccn) ENDIF enddo @@ -299,7 +307,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, vdftra(i,k,11) = qgrs(i,k,ntgnc) vdftra(i,k,12) = qgrs(i,k,ntgv) vdftra(i,k,13) = qgrs(i,k,ntoz) - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN vdftra(i,k,14) = qgrs(i,k,ntccn) ENDIF enddo @@ -314,7 +322,8 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, call set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & imp_physics_thompson, ltaerosol, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, kk, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & errmsg, errflg) if (errflg /= 0) return ! @@ -386,7 +395,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev,nqrimef, & trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, imp_physics_mg, & - imp_physics_fer_hires, imp_physics_nssl2m, imp_physics_nssl2mccn, & + imp_physics_fer_hires, imp_physics_nssl, nssl_ccn_on, & ltaerosol, nssl_hail_on, cplflx, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf,& shinhong, do_ysu, dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, & dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & @@ -407,7 +416,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires - integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn, nssl_hail_on + integer, intent(in) :: imp_physics_nssl, nssl_ccn_on, nssl_hail_on logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu @@ -478,7 +487,8 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, call set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & imp_physics_thompson, ltaerosol, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, kk, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & errmsg, errflg) if (errflg /= 0) return ! @@ -605,7 +615,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntoz) = dvdftra(i,k,3) enddo enddo - elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + elseif (imp_physics == imp_physics_nssl ) then ! nssl IF ( nssl_hail_on ) THEN do k=1,levs @@ -626,7 +636,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntgv) = dvdftra(i,k,14) dqdt(i,k,nthv) = dvdftra(i,k,15) dqdt(i,k,ntoz) = dvdftra(i,k,16) - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN dqdt(i,k,ntccn) = dvdftra(i,k,17) ENDIF enddo @@ -649,7 +659,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntgnc) = dvdftra(i,k,11) dqdt(i,k,ntgv) = dvdftra(i,k,12) dqdt(i,k,ntoz) = dvdftra(i,k,13) - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN dqdt(i,k,ntccn) = dvdftra(i,k,14) ENDIF enddo diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 9a17b34b3..baa45a0c3 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -303,7 +303,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -311,14 +311,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -327,6 +319,14 @@ type = logical intent = in optional = F +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro @@ -788,7 +788,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -796,14 +796,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -812,6 +804,14 @@ type = logical intent = in optional = F +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index b695fe767..10ba643bd 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,9 +18,9 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & - ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, first_time_step, & + imp_physics,imp_physics_nssl, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & imp_physics_fer_hires, julian, yearlen, lndp_var_list, lsswr, lslwr, & @@ -36,7 +36,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & gasvmr_o2, gasvmr_co, gasvmr_cfc11, gasvmr_cfc12, gasvmr_cfc22, & gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, faersw1, faersw2, faersw3, faerlw1, faerlw2, & - faerlw3, alpha, errmsg, errflg) + faerlw3, alpha, errmsg, errflg,mpiroot) use machine, only: kind_phys @@ -78,6 +78,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & make_DropletNumber, & make_RainNumber + use module_mp_nssl_2mom, only: calc_eff_radius, calcnfromq, na + implicit none integer, intent(in) :: im, levs, lm, lmk, lmp, n_var_lndp, & @@ -85,6 +87,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv_gf, me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & ntcw, ntiw, ntlnc, ntinc, & + ntrnc, ntsnc,ntccn, & ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & @@ -94,7 +97,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, & imp_physics_mg, imp_physics_wsm6, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & + imp_physics_nssl, & imp_physics_fer_hires, & yearlen, icloud @@ -102,8 +105,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & logical, intent(in) :: lsswr, lslwr, ltaerosol, lgfdlmprad, & uni_cld, effr_in, do_mynnedmf, & - lmfshal, lmfdeep2, pert_clds + lmfshal, lmfdeep2, pert_clds,first_time_step + logical, intent(in) :: nssl_ccn_on, nssl_invertccn real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd @@ -117,6 +121,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & cnvw_in, cnvc_in, & sppt_wts + real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs, aer_nm real(kind=kind_phys), dimension(:), intent(inout) :: coszen, coszdg @@ -173,6 +178,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + integer, intent(in) :: mpiroot ! Local variables integer :: ncndl @@ -193,6 +199,10 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(im,lm+LTP) :: & re_cloud, re_ice, re_snow, qv_mp, qc_mp, & qi_mp, qs_mp, nc_mp, ni_mp, nwfa + ! for NSSL MP + real(kind=kind_phys), dimension(im,lm+LTP) :: & + re_rain, qr_mp, ns_mp, nr_mp, nh_mp, vh_mp, cccn_mp,cccna_mp, nc_mp2 + real, allocatable :: an(:,:,:,:) ! temporary scalar array ! for F-A MP real(kind=kind_phys), dimension(im,lm+LTP) :: qc_save, qi_save, qs_save @@ -215,6 +225,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & its, ite, jts, jte, kts, kte real(kind=kind_phys) :: qvs + real (kind=kind_phys) :: sum1,sum2,max1,max2 ! !===> ... begin here ! @@ -673,6 +684,30 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo endif if_thompson + if (imp_physics == imp_physics_nssl) then + ! write(6,*) 'rrtm_pre: set qx_mp for NSSL',ntlnc,ntinc,ntsnc,ntrnc + do k=1,LMK +! IF ( me == mpiroot ) write(6,*) 'k,rho: ',k,rho(1,k) + do i=1,IM + qvs = qgrs(i,k,ntqv) + qv_mp (i,k) = qvs/(1.-qvs) + qc_mp (i,k) = tracer1(i,k,ntcw)/(1.-qvs) + qi_mp (i,k) = tracer1(i,k,ntiw)/(1.-qvs) + qs_mp (i,k) = tracer1(i,k,ntsw)/(1.-qvs) + qr_mp (i,k) = tracer1(i,k,ntrw)/(1.-qvs) + nc_mp (i,k) = tracer1(i,k,ntlnc)/(1.-qvs) + ni_mp (i,k) = tracer1(i,k,ntinc)/(1.-qvs) + ns_mp (i,k) = tracer1(i,k,ntsnc)/(1.-qvs) + nr_mp (i,k) = tracer1(i,k,ntrnc)/(1.-qvs) + IF ( nssl_ccn_on ) cccn_mp(i,k) = tracer1(i,k,ntccn)/(1.-qvs) + enddo + enddo +! write(6,*) 'rrtmg_pre: max qctrac,qc,qcphy,nctrac,ccw,ccwphy: ',maxval(qc_mp),maxval(qc), & +! maxval(qc_phys),maxval(nc_mp),maxval(ccw),maxval(ccw_phys) +! write(6,*) 'rrtmg_pre: max ni,ns,nr = ',maxval(ni_mp),maxval(ns_mp),maxval(nr_mp) + ! IF ( maxval(ni_mp) > 1.0 ) write(6,*) 'NI max = ',maxval(ni_mp) + ! IF ( maxval(qi_mp) > 0.01e-3 ) write(6,*) 'QI max = ',maxval(qi_mp) + endif endif do n=1,ncndl do k=1,LMK @@ -765,19 +800,112 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo endif - elseif (imp_physics == imp_physics_nssl2m .or. & - imp_physics == imp_physics_nssl2mccn ) then ! NSSL MP + elseif (imp_physics == imp_physics_nssl ) then ! NSSL MP cldcov = 0.0 if(effr_in) then +! if( kdt > 2 ) then +! IF ( .true. .or. maxval(nc_mp) >= 1.e-20 ) THEN do k=1,lm k1 = k + kd do i=1,im effrl(i,k1) = effrl_inout(i,k)! re_cloud (i,k) effri(i,k1) = effri_inout(i,k)! re_ice (i,k) - effrr(i,k1) = 1000. ! rrain_def=1000. + effrr(i,k1) = effrr_in(i,k) effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) enddo enddo + else + ! calculate radii here, but something is not right with incoming number concentrations + ! IF ( .true. .and. first_time_step ) THEN + IF ( ( maxval(qc_mp) > 1.e-11 .and. maxval(nc_mp) < 1.e-5 ) .or. & + ( maxval(qr_mp) > 1.e-11 .and. maxval(nr_mp) < 1.e-5 ) .or. & + ( maxval(qi_mp) > 1.e-11 .and. maxval(ni_mp) < 1.e-5 ) .or. & + ( maxval(qs_mp) > 1.e-11 .and. maxval(ns_mp) < 1.e-5 ) .or. kdt < 3 ) THEN +! ( maxval(qs_mp) > 1.e-11 .and. maxval(ns_mp) < 1.e-5 ) .or. .true. ) THEN + + allocate( an(im,1,lm,na) ) + an(:,:,:,:) = 0.0 + IF ( .true. .or. kdt <= 3 ) THEN + IF ( me == mpiroot ) THEN +! write(6,*) 'before calcn: max ccw = ',maxval(nc_mp),sum(nc_mp) + nc_mp2 = nc_mp + max1 = maxval(nc_mp) + sum1 = sum(nc_mp) + ENDIF +! IF ( maxval(nc_mp) < 1.e-20 ) THEN + call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & + & qcw=qc_mp,qci=qi_mp, qsw=qs_mp,qrw=qr_mp, & + & ccw=nc_mp,cci=ni_mp, csw=ns_mp,crw=nr_mp, & + & qv=qv_mp, invertccn_flag=nssl_invertccn ) +! ENDIF + IF ( .false. .and. me == mpiroot ) THEN + max2 = maxval(nc_mp) + sum2 = sum(nc_mp) + write(6,*) 'after calcn: max ccw = ',maxval(nc_mp),sum(nc_mp) + IF ( Abs(max1-max2) < 1.0 .and. Abs(sum2-sum1) > 1.0 ) THEN + DO k=1,lm + DO i=1,im + IF ( qc_mp(i,k) > 1.e-6 .and. (nc_mp2(i,k) /= nc_mp(i,k) ) ) THEN + write(6,*) 'i,k,qc,nc1,nc2 = ',i,k,qc_mp(i,k),nc_mp2(i,k),nc_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + ELSE +! call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & +! & qcw=qc_mp, & !qci=qi_mp, & ! qsw=qs_mp,qrw=qr_mp, & +! & ccw=nc_mp, & !cci=ni_mp, & ! csw=ns_mp,crw=nr_mp, & +! & cccn=cccn_mp,qv=qv_mp ) + call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & + & qci=qi_mp, qsw=qs_mp,qrw=qr_mp, & + & cci=ni_mp, csw=ns_mp,crw=nr_mp, & + & qv=qv_mp, invertccn_flag=nssl_invertccn ) + ENDIF + ! write(0,*) 'rrtmg_pre2: ni,ns,nr maxval: ',maxval(ni_mp),maxval(ns_mp),maxval(nr_mp),kdt + + deallocate( an ) + ENDIF + re_cloud = 0 + re_ice = 0 + re_snow = 0 + re_rain = 0 + call calc_eff_radius & + & (nx=im,ny=1,nz=lm,na=1,jyslab=1 & + & ,nor=0,norz=0 & + & ,t1=re_cloud,t2=re_ice,t3=re_snow,t4=re_rain & + & ,qcw=qc_mp,qci=qi_mp,qsw=qs_mp,qrw=qr_mp & + & ,ccw=nc_mp,cci=ni_mp,csw=ns_mp,crw=nr_mp & + & ,dn=rho ) + + do k=1,lm + k1 = k + kd + do i=1,im + IF ( .false. ) THEN + effrl(i,k1) = MAX(2.51E-6, MIN( re_cloud(i,k), 50.E-6))*1.e6 + effri(i,k1) = MAX(10.01E-6, MIN( re_ice(i,k), 125.E-6))*1.e6 + effrs(i,k1) = MAX(25.E-6, MIN( re_snow(i,k), 999.E-6))*1.e6 + ! effri(i,k1) = effri_inout(i,k)! re_ice (i,k) + ! effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) + ELSE + effrl(i,k1) = effrl_inout(i,k)! re_cloud (i,k) + effri(i,k1) = effri_inout(i,k)! re_ice (i,k) + effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) + ENDIF + effrr(i,k1) = MAX(25.E-6, MIN( re_rain(i,k), 2999.E-6))*1.e6 + enddo + enddo + + ! Update global arrays + do k=1,lm + k1 = k + kd + do i=1,im + effrl_inout(i,k) = effrl(i,k1) + effri_inout(i,k) = effri(i,k1) + effrs_inout(i,k) = effrs(i,k1) + enddo + enddo + endif elseif (imp_physics == imp_physics_thompson) then ! Thompson MP @@ -1032,9 +1160,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & effri_inout(:,:), effrs_inout(:,:), & dzb, xlat_d, julian, yearlen, & clouds,cldsa,mtopa,mbota, de_lgth, alpha) ! --- outputs - elseif( imp_physics == imp_physics_nssl2m & - .or. imp_physics == imp_physics_nssl2mccn & - ) then ! Thompson MP + + elseif ( imp_physics == imp_physics_nssl ) then ! NSSL MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv !-- MYNN PBL or convective GF @@ -1045,7 +1172,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo - ! --- use clduni as with the GFDL microphysics. + ! --- use clduni with the NSSL microphysics. ! --- make sure that effr_in=.true. in the input.nml! call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs xlat, xlon, slmsk, dz, delp, IM, LMK, LMP, & @@ -1068,10 +1195,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif ! MYNN PBL or GF - elseif(imp_physics == imp_physics_thompson & -! .or. imp_physics == imp_physics_nssl2m & -! .or. imp_physics == imp_physics_nssl2mccn & - ) then ! Thompson MP + elseif(imp_physics == imp_physics_thompson ) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv !-- MYNN PBL or convective GF diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index e44b8b22c..2dfe22f8d 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -161,6 +161,22 @@ type = integer intent = in optional = F +[ntrnc] + standard_name = index_for_rain_number_concentration + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsnc] + standard_name = index_for_snow_number_concentration + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F [ntrw] standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array long_name = tracer index for rain water @@ -193,6 +209,14 @@ type = integer intent = in optional = F +[ntccn] + standard_name = index_for_cloud_condensation_nuclei_number_concentration + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F [ntwa] standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array long_name = tracer index for water friendly aerosol @@ -209,6 +233,22 @@ type = integer intent = in optional = F +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [ntclamt] standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array long_name = tracer index for cloud amount integer @@ -257,6 +297,14 @@ type = integer intent = in optional = F +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -265,7 +313,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -273,14 +321,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme @@ -1210,3 +1250,11 @@ type = integer intent = out optional = F +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index a9c2d8bc0..8fffe4d65 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -520,7 +520,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, dtidx, ntlnc, & imp_physics_wsm6, imp_physics_fer_hires, prsi, ntinc, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & + imp_physics_nssl, & prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & work1, work2, kpbl, kinver, ras, me, save_lnc, save_inc, & ldiag3d, qdiag3d, index_of_process_conv_trans, & @@ -536,7 +536,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & integer, intent(in ) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, ntsw,& ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & - imp_physics_nssl2m, imp_physics_nssl2mccn ,me, index_of_process_conv_trans + imp_physics_nssl, me, index_of_process_conv_trans integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras @@ -668,7 +668,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & else save_qi(:,:) = clw(:,:,1) endif - else if (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + else if (imp_physics == imp_physics_nssl ) then do k=1,levs do i=1,im clw(i,k,1) = gq0(i,k,ntiw) ! ice @@ -712,10 +712,11 @@ end subroutine GFS_suite_interstitial_4_finalize !! subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_nssl2m,imp_physics_nssl2mccn, nssl_invertccn, otsptflag, ntracp1, & + imp_physics_nssl, nssl_invertccn, nssl_ccn_on, nssl_invertccn, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) + otsptflag, ntracp1, errmsg, errflg) use machine, only: kind_phys use module_mp_nssl_2mom, only: qccn @@ -730,10 +731,10 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr integer, intent(in) :: ntracp1 integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl2m, imp_physics_nssl2mccn + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl logical, intent(in) :: ltaerosol, convert_dry_rho - logical, intent(in) :: nssl_invertccn + logical, intent(in) :: nssl_ccn_on, nssl_invertccn real(kind=kind_phys), intent(in ) :: con_pi, dtf real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc @@ -852,14 +853,14 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo enddo - if ( .true. .and. ( imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) ) then + if ( .true. .and. ( imp_physics == imp_physics_nssl ) ) then liqm = con_pi/6.*1.e3*(40.e-6)**3 ! 4./3.*con_pi*1.e-12 icem = con_pi/6.*1.e3*(120.e-6)**3 ! 4./3.*con_pi*3.2768*1.e-14*890. ! qccn = nssl_cccn/1.225 do k=1,levs do i=1,im ! check number of available ccn - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN IF ( nssl_invertccn ) THEN xccn = qccn - gq0(i,k,ntccn) ELSE @@ -884,7 +885,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr IF ( xccn > 0.0 ) THEN xccw = Min( xccn, max(0.0, (clw(i,k,2)-save_qc(i,k))) / xcwmas ) gq0(i,k,ntlnc) = gq0(i,k,ntlnc) + xccw - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN IF ( nssl_invertccn ) THEN ! ccn are activated CCN, so add gq0(i,k,ntccn) = gq0(i,k,ntccn) + xccw diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 2b2299d65..cd31f8619 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1427,7 +1427,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -1435,14 +1435,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [prsi] standard_name = air_pressure_at_interface long_name = air pressure at model layer interfaces @@ -1895,7 +1887,7 @@ type = logical intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -1903,12 +1895,12 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none dimensions = () - type = integer + type = logical intent = in optional = F [nssl_invertccn] diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 10c9ab99e..6beae0da2 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -27,8 +27,8 @@ end subroutine maximum_hourly_diagnostics_finalize #endif subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, & imp_physics_gfdl, imp_physics_thompson, & - imp_physics_fer_hires, imp_physics_nssl2m, & - imp_physics_nssl2mccn, con_g, phil, & + imp_physics_fer_hires, imp_physics_nssl, & + con_g, phil, & gt0, refl_10cm, refdmax, refdmax263k, u10m, v10m, & u10max, v10max, spd10max, pgr, t2m, q2m, t02max, & t02min, rh02max, rh02min, dtp, rain, pratemax, & @@ -38,7 +38,7 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, integer, intent(in) :: im, levs logical, intent(in) :: reset, lradar integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires, & - imp_physics_nssl2m, imp_physics_nssl2mccn + imp_physics_nssl real(kind_phys), intent(in ) :: con_g real(kind_phys), intent(in ) :: phil(:,:) real(kind_phys), intent(in ) :: gt0(:,:) @@ -76,13 +76,12 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, if (lradar .and. (imp_physics == imp_physics_gfdl .or. & imp_physics == imp_physics_thompson .or. & imp_physics == imp_physics_fer_hires .or. & - imp_physics == imp_physics_nssl2m .or. & - imp_physics == imp_physics_nssl2mccn)) then + imp_physics == imp_physics_nssl )) then allocate(refd(im)) allocate(refd263k(im)) call max_fields(phil,refl_10cm,con_g,im,levs,refd,gt0,refd263k) if (reset) then - IF ( imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) THEN + IF ( imp_physics == imp_physics_nssl ) THEN ! ERM: might not need this as a separate assignment do i=1,im refdmax(i) = 0. refdmax263k(i) = 0. diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 53988a164..fd764dc1d 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -71,7 +71,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -79,14 +79,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index a117bb145..c16d539b1 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -64,6 +64,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & qgrs_ozone, & & qgrs_water_aer_num_conc, & & qgrs_ice_aer_num_conc, & + & qgrs_cccn, & & prsl,exner, & & slmsk,tsurf,qsfc,ps, & & ust,ch,hflx,qflx,wspd,rb, & @@ -95,6 +96,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_ice_cloud, dqdt_ozone, & ! <=== ntiw, ntoz & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & ! <=== ntlnc, ntinc & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc, & ! <=== ntwa, ntia + & dqdt_cccn, & ! <=== ntccn & flag_for_pbl_generic_tend, & & dtend, dtidx, index_of_temperature, & & index_of_x_wind, index_of_y_wind, ntke, & @@ -108,7 +110,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & imp_physics_nssl2m, imp_physics_nssl2mccn, & + & imp_physics_nssl, nssl_ccn_on, & & ltaerosol, lprnt, errmsg, errflg ) ! should be moved to inside the mynn: @@ -196,7 +198,7 @@ SUBROUTINE mynnedmf_wrapper_run( & ! NAMELIST OPTIONS (INPUT): LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect, ltaerosol, & lprnt, do_mynnsfclay, & - flag_for_pbl_generic_tend + flag_for_pbl_generic_tend, nssl_ccn_on INTEGER, INTENT(IN) :: & & bl_mynn_cloudpdf, & & bl_mynn_mixlength, & @@ -212,7 +214,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & grav_settling, & & imp_physics, imp_physics_wsm6, & & imp_physics_thompson, imp_physics_gfdl, & - & imp_physics_nssl2m, imp_physics_nssl2mccn + & imp_physics_nssl !TENDENCY DIAGNOSTICS real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) @@ -254,6 +256,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_water_vapor, dqdt_liquid_cloud, dqdt_ice_cloud, & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_ozone, dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc + real(kind=kind_phys), dimension(:,:), intent(inout) ::dqdt_cccn real(kind=kind_phys), dimension(:,:), intent(inout) :: & & qke, qke_adv, EL_PBL, Sh3D, & & qc_bl, qi_bl, cldfra_bl @@ -273,6 +276,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & qgrs_ozone, & & qgrs_water_aer_num_conc, & & qgrs_ice_aer_num_conc + real(kind=kind_phys), dimension(:,:), intent(in) ::qgrs_cccn real(kind=kind_phys), dimension(:,:), intent(out) :: & & Tsq, Qsq, Cov, exch_h, exch_m real(kind=kind_phys), dimension(:), intent(in) :: xmu @@ -400,14 +404,15 @@ SUBROUTINE mynnedmf_wrapper_run( & qnifa(i,k) = 0. enddo enddo - elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + elseif (imp_physics == imp_physics_nssl ) then ! NSSL FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. FLAG_QNC= .true. - FLAG_QNWFA= .false. + FLAG_QNWFA= nssl_ccn_on ! ERM: Perhaps could use this field for CCN field? FLAG_QNIFA= .false. + ! p_q vars not used? p_qc = 2 p_qr = 0 p_qi = 2 @@ -424,6 +429,9 @@ SUBROUTINE mynnedmf_wrapper_run( & qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) qnwfa(i,k) = 0. + IF ( nssl_ccn_on ) THEN + qnwfa(i,k) = qgrs_cccn(i,k) + ENDIF qnifa(i,k) = 0. enddo enddo @@ -872,6 +880,21 @@ SUBROUTINE mynnedmf_wrapper_run( & ! enddo !enddo endif !end thompson choice + elseif (imp_physics == imp_physics_nssl) then + ! NSSL + do k=1,levs + do i=1,im + dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) + dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) + IF ( nssl_ccn_on ) THEN ! + dqdt_cccn(i,k) = RQNWFABLTEN(i,k) + ENDIF + enddo + enddo + elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP do k=1,levs diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 2ff9f7f61..a35ab4e7b 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -378,6 +378,15 @@ kind = kind_phys intent = in optional = F +[qgrs_cccn] + standard_name = cloud_condensation_nuclei_number_concentration + long_name = number concentration of cloud condensation nuclei + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [prsl] standard_name = air_pressure long_name = mean layer pressure @@ -1119,6 +1128,15 @@ kind = kind_phys intent = inout optional = F +[dqdt_cccn] + standard_name = tendency_of_cloud_condensation_nuclei_number_concentration_due_to_model_physics + long_name = number concentration of cloud condensation nuclei tendency due to model physics + units = kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [flag_for_pbl_generic_tend] standard_name = flag_for_generic_tendency_due_to_planetary_boundary_layer long_name = true if GFS_PBL_generic should calculate tendencies @@ -1419,7 +1437,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -1427,12 +1445,12 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none dimensions = () - type = integer + type = logical intent = in optional = F [ltaerosol] diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 174cca092..0a8532de1 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1,7 +1,7 @@ !WRF:MODEL_LAYER:PHYSICS -! prepocessed on "Apr 18 2021" at "20:33:31" +! prepocessed on "Sep 30 2021" at "11:13:44" @@ -75,6 +75,32 @@ ! ! !--------------------------------------------------------------------- +! Sept. 2021: +! Fixes: +! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed density independent of size. Generally low reflectivity values as a result (no effect on microphysics) +! Other: +! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect) +! Reordered collection coefficients (dab1lh) to be consistent (no effect) +! Switched to full calculation of rain number loss via collection by graupel (chacr; to be consisted with collection by hail) (minor effects) +!--------------------------------------------------------------------- +! April 2021: +! Fixes: +! Fall speed air density factor limited to air density of 0.05 (for very high model top) to mitigate excessive fall speeds +! Fixed issue of spurious creation of large concentrations of very small droplets and transient large condensation (also increased minimum droplet size) +! Fixed issue of negligible "seed" values of graupel from Bigg freezing at relatively high temperatures (thanks to S. Lasher-Trapp) +! Minor bug fix in effective radius calculation of snow. (thanks to T. Iguchi) +! Updates: +! Enabled regeneration of CCN by droplet evaporation and background restore (default time constant of 3600s) +! Updated the routine that handles single-moment variables on the first time step. This sets a higher threshold for meaningful mixing ratios and sets a more realistic droplet concentration (also activating CCN as needed). +! Enabled radar reflectivity from cloud ice (new formulation) ( idbzci = 1 ) +! Added internal option for ice crystal nucleation by DeMott et al. (2010, PNAS) (inucopt=4) +! Allow greater fraction of hail to melt in one time step +! Reduced minimum number concentration from 1e-4 to 1e-8 (based on CAPS input) +! Added internal namelist for easier access to internal variables for development/testing and easier setup for ensemble microphysics diversity +! (namelist read is disabled by default) +! Increased resolution of lookup table for incomplete gamma functions +! +!--------------------------------------------------------------------- ! Sept. 2019: ! Bug fixes: ! - Effective radius calculation was only done at history times. Now every time step (though should be just before radiation is called) @@ -143,11 +169,13 @@ MODULE module_mp_nssl_2mom - + use physcons, only: con_pi, con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps IMPLICIT NONE public nssl_2mom_driver public nssl_2mom_init + public calc_eff_radius + public calcnfromq private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis private gamma_dp, gamxinfdp, gamma_dpr private delbk, delabk @@ -156,21 +184,13 @@ MODULE module_mp_nssl_2mom logical, private :: cleardiag = .false. PRIVATE -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) integer, parameter :: wrfchem_flag = 1 #else integer, parameter :: wrfchem_flag = 0 #endif LOGICAL, PRIVATE:: is_aerosol_aware = .false. -! From ThompsonAero: -! Declaration of constants for assumed CCN/IN aerosols when none in -! the input data. Look inside the init routine for modifications -! due to surface land-sea points or vegetation characteristics. - REAL, PARAMETER, PRIVATE:: naIN0 = 1.5E6 - REAL, PARAMETER, PRIVATE:: naIN1 = 0.5E6 - REAL, PARAMETER, PRIVATE:: naCCN0 = 300.0E6 - REAL, PARAMETER, PRIVATE:: naCCN1 = 50.0E6 logical, private :: turn_on_cin = .false. @@ -194,8 +214,7 @@ MODULE module_mp_nssl_2mom integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) ! =2 turn on for graupel density less than 300. only integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) - integer :: iusewetsnow = 1 ! =1 to turn on diagnosed bright band - + integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band ! microphysics real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params @@ -216,6 +235,7 @@ MODULE module_mp_nssl_2mom real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value real , public :: qccn ! ccn "mixing ratio" + real , private :: old_qccn = -1.0 integer, private :: iauttim = 1 ! 10-ice rain delay flag real , private :: auttim = 300. ! 10-ice rain delay time real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual @@ -226,10 +246,11 @@ MODULE module_mp_nssl_2mom #else logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state #endif + logical :: switchccn = .false. + real :: old_cccn = -1.0 logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) - ! sedimentation flags ! itfall -> 0 = 1st order fallout (other options removed) ! iscfall, infall -> fallout options for charge and number concentration, respectively @@ -237,9 +258,10 @@ MODULE module_mp_nssl_2mom integer, private :: itfall = 0 integer, private :: iscfall = 1 integer, private :: irfall = -1 - logical, private :: do_accurate_sedimentation = .false. ! if true, recalculate fall speeds on sub time steps; (more expensive) + logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive) ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) ! Mainly is an issue for small dz near the surface. + integer, private :: interval_sedi_vt = 1 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.) integer, private :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) ! 1 -> uses mass-weighted fallspeed for N ALWAYS ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS) @@ -277,11 +299,12 @@ MODULE module_mp_nssl_2mom real, private :: cimn = 1.0e3, cimx = 1.0e6 - + real , private :: rhofrz = 900 ! density of freezing drops real , private :: ifrzg = 1.0 ! fraction of frozen drops (Bigg freezing) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail real , private :: ifiacrg = 1.0 ! fraction of frozen drops (3-component freezing qiacr) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail real , private :: ifrzs = 1.0 ! fraction of small frozen drops going to snow. 1=freeze rain to snow, 0=freeze to cloud ice real , private :: ffrzs = 0.0 ! fraction of other initiated cloud ice going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + real , private :: f2h = 1.0 ! fraction of cloud ice conversion going to graupel (vs. frozen drops). For testing integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget) integer, private :: irimtim = 0 ! future use ! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds @@ -309,7 +332,7 @@ MODULE module_mp_nssl_2mom real :: renucfrac = 0.0 ! = 0 : cnuc = cwccn ! = 1 : cnuc = actual available CCN ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac - real :: ssf2kmax = 1.05 ! max value for ssf**cck in irenuc=4 + real :: ssf2kmax = 10. ! max value for ssf**cck in irenuc=4 or 5 real , private :: cck = 0.6 ! exponent in Twomey expression real , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation @@ -354,6 +377,7 @@ MODULE module_mp_nssl_2mom logical, private :: imeyers5 = .false. ! .false.=off, true=on for Meyers ice nucleation for temp > -5 C real , private :: dmincw = 15.0e-6 ! minimum droplet diameter for collection for iehw=3 integer, private :: iehw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data + integer, private :: iefw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data integer, private :: iehlw = 1 ! 0 -> ehlw=ehlw0; 1 -> old ehlw; 2 -> test ehlw with Mason table data ! For ehw/ehlw = 1, ehw0/ehlw0 act as maximum limit on collection efficiency (defaults are 1.0) integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) @@ -362,7 +386,9 @@ MODULE module_mp_nssl_2mom real , private :: ehw0 = 0.9 ! constant or max assumed graupel-droplet collection efficiency real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency real , private :: ehlw0 = 0.9 ! constant or max assumed hail-droplet collection efficiency + real , private :: efw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency + real :: efr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency real :: ehlr0 = 1.0 ! constant or max assumed hail-rain collection efficiency real , private :: exwmindiam = 0.0 ! minimum diameter of droplets for riming. If set > 0, will exclude that fraction of mass/number from accretion (idea from Furtado and Field 2017 JAS but also Fierro and Mansell 2017) @@ -430,6 +456,7 @@ MODULE module_mp_nssl_2mom ! and for ciacrf for iacr=4 real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail + integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail integer, private :: imltshddmr = 2 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail @@ -546,6 +573,7 @@ MODULE module_mp_nssl_2mom integer, private :: ibiggsnow = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction ! 3 = switch conversion over to snow for small frozen drops from both + real :: biggsnowdiam = -1.0 ! If >0, use for ibiggsnow threshold integer, private :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi) @@ -591,6 +619,7 @@ MODULE module_mp_nssl_2mom integer, private :: lis = 0 integer, private :: ls = 6 integer, private :: lh = 7 + integer, private :: lf = 0 integer, private :: lhl = 0 integer, private :: lccn = 9 ! 0 or 9, other indices adjusted accordingly @@ -604,7 +633,10 @@ MODULE module_mp_nssl_2mom integer, private :: lnis = 0 integer, private :: lns = 12 integer, private :: lnh = 13 + integer, private :: lnf = 0 integer, private :: lnhl = 0 + integer, private :: lnhf = 0 + integer, private :: lnhlf = 0 integer, private :: lss = 0 integer :: lvh = 15 @@ -624,6 +656,7 @@ MODULE module_mp_nssl_2mom ! liquid water fraction (not predicted here but tested for) integer :: lhw = 0 + integer :: lfw = 0 integer :: lsw = 0 integer :: lhlw = 0 integer :: lhwlg = 0 @@ -649,6 +682,7 @@ MODULE module_mp_nssl_2mom integer :: lscis = 0 integer :: lscs = 0 integer :: lsch = 0 + integer :: lscf = 0 integer :: lschl = 0 integer :: lscwi = 0 integer :: lscpi = 0 @@ -780,7 +814,6 @@ MODULE module_mp_nssl_2mom ! ! constants ! - real, parameter :: cp608 = 0.608 ! constant used in conversion of T to Tv real, parameter :: ar = 841.99666 ! rain terminal velocity power law coefficient (LFO) real, parameter :: br = 0.8 ! rain terminal velocity power law coefficient (LFO) real, parameter :: aradcw = -0.27544 ! @@ -797,11 +830,12 @@ MODULE module_mp_nssl_2mom ! new values for cs and ds real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient - real, parameter :: pi = 3.141592653589793 + real, parameter :: cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv + real, parameter :: pi = con_pi real, parameter :: piinv = 1./pi real, parameter :: pid4 = pi/4.0 - real, parameter :: gr = 9.8 + real, parameter :: gr = con_g ! ! max and min mean volumes @@ -865,13 +899,14 @@ MODULE module_mp_nssl_2mom real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation real, parameter :: cawbolton = 17.67 - real, parameter :: tfr = 273.15, tfrh = 233.15 + real, parameter :: tfr = con_t0c, tfrh = 233.15 - real, parameter :: cp = 1004.0, rd = 287.04 + real, parameter :: cp = con_cp, rd = con_rd, rw = con_rv + REAL, PRIVATE, parameter :: cpl = con_cliq ! 4190.0 + REAL, PRIVATE, parameter :: cpigb = con_csol ! 2106.0 real, parameter :: cpi = 1./cp real, parameter :: cap = rd/cp, poo = 1.0e+05 - real, parameter :: rw = 461.5 ! gas const. for water vapor real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity @@ -882,8 +917,6 @@ MODULE module_mp_nssl_2mom ! REAL, PRIVATE :: cv = cp - rd real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air REAL, PRIVATE, parameter :: cvv = 1408.5 - REAL, PRIVATE, parameter :: cpl = 4190.0 - REAL, PRIVATE, parameter :: cpigb = 2106.0 ! GHB real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) @@ -892,7 +925,7 @@ MODULE module_mp_nssl_2mom real :: cckm,ccne,ccnefac,cnexp,CCNE0 - integer :: na = 9 + integer, public :: na = 9 integer :: nxtra = 1 real gf4p5, gf4ds, gf4br real gsnow1, gsnow53, gsnow73 @@ -913,6 +946,10 @@ MODULE module_mp_nssl_2mom logical, parameter :: do_satadj_for_wrfchem = .true. +! Note to users: Many of these options are for development and not guaranteed to perform well. +! Some may not be functional depending on the version of the code. +! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions +! in that regard. NAMELIST /nssl_mp_params/ & ndebug, ncdebug,& iusewetgraupel, & @@ -932,6 +969,7 @@ MODULE module_mp_nssl_2mom icnuclimit, & irenuc, & restoreccn, ccntimeconst, cck, & + switchccn, old_cccn, & ciintmx, & itype1, itype2, & icenucopt, & @@ -1046,8 +1084,8 @@ MODULE module_mp_nssl_2mom delta_alphamlr, & iqvsopt, & maxsupersat, & - charging_border - + charging_border, & + do_accurate_sedimentation, interval_sedi_vt ! ##################################################################### ! ##################################################################### @@ -1123,7 +1161,9 @@ SUBROUTINE nssl_2mom_init( & & nssl_icdx, & & nssl_icdxhl, & & nssl_icefallfac, & - & nssl_snowfallfac & + & nssl_snowfallfac, & + & errmsg, errflg, & + & myrank, mpiroot & ) implicit none @@ -1137,8 +1177,11 @@ SUBROUTINE nssl_2mom_init( & & nssl_snowfallfac integer, intent(in), optional :: & & nssl_icdx, & - & nssl_icdxhl + & nssl_icdxhl, myrank, mpiroot + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg integer, intent(in) :: ims,ime, jms,jme, kms,kme real, intent(in), dimension(20) :: nssl_params @@ -1146,6 +1189,10 @@ SUBROUTINE nssl_2mom_init( & integer, intent(in) :: ipctmp,mixphase,ihvol logical, optional, intent(in) :: idoniconlytmp + + logical :: wrote_namelist = .false. + logical :: wrf_dm_on_monitor + double precision :: arg real :: temq integer :: igam @@ -1160,6 +1207,8 @@ SUBROUTINE nssl_2mom_init( & integer :: istat + errmsg = '' + errflg = 0 turn_on_ccna = .false. turn_on_cina = .false. ! @@ -1199,6 +1248,25 @@ SUBROUTINE nssl_2mom_init( & + IF ( .true. ) THEN ! set to true to enable internal namelist read + open(15,file='input.nml',status='old',form='formatted',action='read') + rewind(15) + read(15,NML=nssl_mp_params,iostat=istat) + close(15) + IF ( present ( myrank ) .and. present ( mpiroot ) ) THEN + IF ( myrank == mpiroot ) THEN + IF ( istat /= 0 ) THEN + write(0,*) 'READ_NAMELIST: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + ENDIF + +! write(0,*) 'iusewetsnow = ',iusewetsnow + + open(15,file='nssl_mp_params.out',status='unknown',form='formatted') + write(15,NML=nssl_mp_params) + close(15) + ENDIF + ENDIF + ENDIF @@ -1450,8 +1518,9 @@ SUBROUTINE nssl_2mom_init( & ! ltmp = lhlw ENDIF ELSEIF ( ipconc >= 6 ) THEN - write(0,*) 'NSSL microphysics has not been compiled for 3-moment. Sorry.' - STOP + errmsg = 'NSSL microphysics has not been compiled for 3-moment. Sorry.' + errflg = 1 + return lccn = lhab+1 ! 9 lnc = lhab+2 ! 10 lnr = lhab+3 ! 11 @@ -1752,6 +1821,11 @@ SUBROUTINE nssl_2mom_init( & IF ( lzr > 0 ) irfall = 0 qccn = ccn/rho00 + IF ( old_cccn > 0.0 ) THEN + old_qccn = old_cccn/rho00 + ELSE + old_qccn = qccn + ENDIF ! xvcmx = (4./3.)*pi*xcradmx**3 ! set max rain diameter @@ -1956,12 +2030,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & SR,HAILNC, HAILNCV, & tkediss, & - re_cloud, re_ice, re_snow, & - has_reqc, has_reqi, has_reqs, & + re_cloud, re_ice, re_snow, re_rain, & + has_reqc, has_reqi, has_reqs, has_reqr, & rainncw2, rainnci2, & dbz, vzf,compdbz, & rscghis_2d,rscghis_2dp,rscghis_2dn, & scr,scw,sci,scs,sch,schl,sctot, & + elec_physics, & induc,elec,scion,sciona, & noninduc,noninducp,noninducn, & pcc2, pre2, depsubr, & @@ -1978,13 +2053,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & ipelectmp, & diagflag,ke_diag, & - NWFA, f_qnwfa, & - NIFA, f_qnifa, & - nwfa2d, & - qnn2d, & + errmsg, errflg, & nssl_progn, & ! wrf-chem ! 20130903 acd_mb_washout start - rainprod, evapprod, & ! wrf-chem + wetscav_on, rainprod, evapprod, & ! wrf-chem ! 20130903 acd_mb_washout end cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added ids,ide, jds,jde, kds,kde, & ! domain dims @@ -1993,21 +2065,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw -#if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) -#define MPI - USE module_dm, ONLY : & - local_communicator, mytask -! keep a spacing line here to keep Apple cpp from adding a space in front of the endif -#endif - implicit none -#if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) || defined(MPI) - INCLUDE 'mpif.h' -#else - integer :: mytask = 0 - -#endif !Subroutine arguments: @@ -2029,6 +2088,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) rscghis_2dn ! 2D accumulation arrays for vertically-integrated charging rate (negative only) ! real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d + integer, optional, intent(in) :: elec_physics real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & @@ -2061,11 +2121,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: & - re_cloud, re_ice, re_snow, nwfa, nifa - real, dimension(ims:ime, jms:jme), intent(in), optional :: nwfa2d,qnn2d + integer, parameter :: nproc = 1 + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, re_rain REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss - INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr real, dimension(ims:ime, jms:jme), intent(out), optional :: & rainncw2, rainnci2 ! liquid rain, ice, accumulation rates real, optional, intent(in) :: dx,dy @@ -2074,12 +2133,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina integer, optional, intent(in) :: ipelectmp, ke_diag + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem - LOGICAL, INTENT(IN), OPTIONAL :: f_qnifa , f_qnwfa ! flags for Thompson aero ! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop LOGICAL :: flag_qndrop ! wrf-chem LOGICAL :: flag_qnifa , flag_qnwfa + logical :: flag real :: cinchange, t7max,testmax,wmax ! 20130903 acd_ck_washout start @@ -2094,6 +2157,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! mu : air mass in column REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: qrcuten, qscuten, qicuten, qccuten INTEGER, optional, intent(in) :: cu_used + LOGICAL, optional, intent(in) :: wetscav_on ! ! local variables @@ -2106,6 +2170,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d real, dimension(its:ite, 1, na) :: xfall + real, dimension(kts:kte, nproc) :: thproclocal integer, parameter :: nor = 0, ng = 0 integer :: nx,ny,nz integer ix,jy,kz,i,j,k,il,n @@ -2118,6 +2183,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real :: dbzmx,refl integer :: vzflag0 = 0 logical :: makediag + real :: dx1,dy1 real, parameter :: cnin20 = 1.0e3 real, parameter :: cnin10 = 5.0e1 real, parameter :: cnin1a = 4.5 @@ -2139,10 +2205,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw double precision :: timevtcalc,timesetvt logical :: f_cnatmp, f_cinatmp + logical :: has_wetscav integer :: kediagloc integer :: iunit + real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot + real :: fach(kts:kte) + #ifdef MPI #if defined(MPI) @@ -2155,6 +2225,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ------------------------------------------------------------------- + errmsg = '' + errflg = 0 rdt = 1.0/dtp @@ -2166,8 +2238,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn - IF ( PRESENT ( f_qnifa ) ) flag_qnifa = f_qnifa - IF ( PRESENT ( f_qnwfa ) ) flag_qnwfa = f_qnwfa @@ -2202,6 +2272,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ENDDO ! ENDIF + IF ( present( dx ) .and. present( dy ) ) THEN + dx1 = dx + dy1 = dy + ELSE + dx1 = 1.0 + dy1 = 1.0 + ENDIF + makediag = .true. IF ( present( diagflag ) ) THEN @@ -2218,10 +2296,26 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( .not. present( cn ) ) THEN renucfrac = 1.0 ENDIF + + + + IF ( switchccn .and. lccna > 1 .and. .not. invertccn) THEN + ! hack to switch from ccn to ccna from a restart + + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cn(ix,kz,jy) = Max( 0.0, old_qccn - cn(ix,kz,jy) ) + ENDDO + ENDDO + ENDDO + switchccn = .false. + ENDIF ! ENDIF ! itimestep == 1 + ! sedimentation settings infdo = 2 @@ -2307,7 +2401,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) an(ix,1,kz,lhl) = qhl(ix,kz,jy) IF ( lccn > 1 ) THEN IF ( is_aerosol_aware .and. flag_qnwfa ) THEN - an(ix,1,kz,lccn) = nwfa(ix,kz,jy) + ! ELSEIF ( present( cn ) ) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN an(ix,1,kz,lccna) = cn(ix,kz,jy) @@ -2337,10 +2431,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF - IF ( lcin > 1 .and. flag_qnifa ) THEN - an(ix,1,kz,lcin) = nifa(ix,kz,jy) - ENDIF - IF ( ipconc >= 5 ) THEN an(ix,1,kz,lnc) = ccw(ix,kz,jy) IF ( constccw > 0.0 ) THEN @@ -2480,9 +2570,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! ix ENDDO ! kz + has_wetscav = .false. IF ( wrfchem_flag > 0 ) THEN - IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 - IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( wetscav_on ) ) THEN + has_wetscav = wetscav_on + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF + ENDIF ENDIF @@ -2509,6 +2605,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( itimestep == 1 .and. ipconc > 0 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) ENDIF +! IF ( itimestep == 3 .and. ipconc > 0 ) THEN +! call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) +! ENDIF ! #endif IF ( present(cu_used) .and. & @@ -2565,7 +2664,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) - IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + IF ( present( GRPLNCV ) ) THEN + IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) + ELSE + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + ENDIF + ENDIF RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) @@ -2577,8 +2682,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw !#endif HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) - ELSEIF ( present( GRPLNCV ) ) THEN - GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) +! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel +! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) ENDIF ENDIF IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) @@ -2600,7 +2705,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! IF ( isedonly /= 2 ) THEN - IF ( .true. ) THEN call nssl_2mom_gs & & (nx,ny,nz,na,jy & & ,nor,nor & @@ -2614,12 +2718,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,dbz2d,tke2d, & + & thproclocal,nproc,dx1,dy1, & & timevtcalc,axtra2d, makediag & - & ,rainprod2d, evapprod2d & - & ,elec2,its,ids,ide,jds,jde & + & ,has_wetscav, rainprod2d, evapprod2d & + & ,errmsg,errflg & + & ,elec2,its,ids,ide,jds,jde & & ) - ENDIF - @@ -2635,6 +2739,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,t0,t9 & & ,an,dn1,t77 & & ,pn,wn & + & ,thproclocal,nproc,dx1,dy1,dz2d & & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) @@ -2642,6 +2747,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF + IF ( present( pcc2 ) .and. makediag ) THEN DO kz = kts,kte DO ix = its,ite @@ -2703,14 +2809,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw t1(ix,1,kz) = 2.51E-6 t2(ix,1,kz) = 10.01E-6 t3(ix,1,kz) = 25.E-6 + t4(ix,1,kz) = 50.e-6 ENDDO ENDDO + call calc_eff_radius & & (nx,ny,nz,na,jy & & ,nor,nor & - & ,t1,t2,t3 & - & ,an,dn1 ) + & ,t1=t1,t2=t2,t3=t3,t4=t4 & + & ,an=an,dn=dn1 ) DO kz = kts,kte DO ix = its,ite @@ -2721,6 +2829,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) ENDDO ENDDO + + IF ( present(has_reqr) .and. present( re_rain ) ) THEN + IF ( has_reqr /= 0 ) THEN + re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t3(ix,1,kz), 2999.E-6)) + ENDIF + ENDIF ENDIF ENDIF @@ -2760,9 +2874,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN - nwfa(ix,kz,jy) = an(ix,1,kz,lccn) -! nwfa(ix,kz,jy) = Min(1.5e9, nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp) - IF ( kz == 1 ) nwfa(ix,kz,jy) = nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp + ! not used here ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN IF ( lccna > 1 .and. .not. present( cna ) ) THEN cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) @@ -2782,10 +2894,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF - IF ( lcin > 1 .and. flag_qnifa ) THEN - nifa(ix,kz,jy) = an(ix,1,kz,lcin) - ENDIF - IF ( ipconc >= 5 ) THEN ccw(ix,kz,jy) = an(ix,1,kz,lnc) @@ -2802,12 +2910,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lvh > 0 ) vhw(ix,kz,jy) = an(ix,1,kz,lvh) IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl) -#ifdef WRF_CHEM - IF ( wrfchem_flag > 0 ) THEN +#if ( WRF_CHEM == 1 ) + IF ( has_wetscav ) THEN IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) ENDIF #endif + ENDDO ENDDO @@ -3677,7 +3786,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO n = 1,ndfall - IF ( do_accurate_sedimentation .and. n .ge. 2 ) THEN + IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN ! ! zero the precip flux arrays (2d) ! @@ -4279,13 +4388,17 @@ END subroutine calcnfromz1d ! ############################################################################## ! ! Subroutine to calculate number concentrations from initial state that has only mixing ratio. -! N will be in #/kg, NOT #/m^3, since sedimentation is done next. -! +! Output N will be in #/m^3 in 'an' array, since sedimentation is done next. +! Output ccw,cci etc. will be in #/kg ! ! 10.27.2015: Added hail calculation ! - subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) + subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & + & qcw,qci,qsw,qrw,qhw,qhl, & + & ccw,cci,csw,crw,chw,chl, & + & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin ) + implicit none @@ -4295,6 +4408,12 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) real dn(nx,nz+1) ! air density + + real, optional, dimension(nx,nz), intent(inout) :: qcw,qci,qsw,qrw,qhw,qhl, & + ccw,cci,csw,crw,chw,chl, & + cccn,cccna,vhw,vhl,qv, spechum + logical, optional, intent(in) :: invertccn_flag + real, optional :: cwmasin integer ixe,kze real alpha @@ -4306,7 +4425,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) integer ix,jy,kz - double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 @@ -4319,11 +4438,24 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx) real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet - real xv,xdn + real xv,xdn,cwmasinv integer :: ndbz, nmwgt, nnwgt, nwlessthanz + double precision :: mixconv, mixconvqv, qsmax,qsmax2,qsmax3,qsmax4 + logical :: invertccn_local ! ------------------------------------------------------------------ + IF ( present( invertccn_flag ) ) THEN + invertccn_local = invertccn_flag + ELSE + invertccn_local = .false. + ENDIF + + IF ( present( cwmasin ) ) THEN + cwmasinv = 1.0/cwmasin + ELSE + cwmasinv = 1.0/cwmas09 + ENDIF jy = 1 @@ -4342,18 +4474,59 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF g1s = (snu+2.0)/(snu+1.0) - + qsmax = 0 + qsmax2 = 0 + qsmax3 = 0 + qsmax4 = 0 +! IF ( .not. present( qcw ) ) THEN DO kz = 1,nz DO ix = 1,nx ! ixcol +! qv_mp = spechum/(1.0_kind_phys-spechum) +! IF ( convertdry ) THEN +! qc_mp = qc/(1.0_kind_phys-spechum) + mixconv = 1 + IF ( present( spechum ) ) THEN ! convert to "dry" mixing ratios + an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconv = 1.0d0/(1.0d0 - spechum(ix,kz)) + ELSE + mixconv = 1.0d0 + ENDIF + IF ( present( qv ) ) an(ix,jy,kz,lv) = qv(ix,kz) ! assume qv is "dry" mixing ratio if passed in + IF ( present( qcw ) ) an(ix,jy,kz,lc) = qcw(ix,kz)*mixconv + IF ( present( qrw ) ) an(ix,jy,kz,lr) = qrw(ix,kz)*mixconv + IF ( present( qci ) ) an(ix,jy,kz,li) = qci(ix,kz)*mixconv + IF ( present( qsw ) ) THEN + an(ix,jy,kz,ls) = qsw(ix,kz)*mixconv +! qsmax = Max( qsmax, qsw(ix,kz) ) +! qsmax2 = Max( qsmax2, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) an(ix,jy,kz,lh) = qhw(ix,kz)*mixconv + IF ( lhl > 1 .and. present( qhl ) ) an(ix,jy,kz,lhl) = qhl(ix,kz)*mixconv + IF ( present( ccw ) ) an(ix,jy,kz,lnc) = ccw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( crw ) ) an(ix,jy,kz,lnr) = crw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( cci ) ) an(ix,jy,kz,lni) = cci(ix,kz)*mixconv*dn(ix,kz) + IF ( present( csw ) ) an(ix,jy,kz,lns) = csw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( chw ) ) an(ix,jy,kz,lnh) = chw(ix,kz)*mixconv*dn(ix,kz) + IF ( lhl > 1 .and. present( chl ) ) an(ix,jy,kz,lnhl) = chl(ix,kz)*mixconv*dn(ix,kz) + IF ( lvh > 1 .and. present( vhw ) ) an(ix,jy,kz,lvh) = vhw(ix,kz)*mixconv + IF ( lvhl > 1 .and. present( vhl ) ) an(ix,jy,kz,lvhl) = vhl(ix,kz)*mixconv + IF ( lccn > 1 .and. present( cccn ) ) an(ix,jy,kz,lccn) = cccn(ix,kz)*mixconv*dn(ix,kz) + IF ( lccna > 1 .and. present( cccna ) ) an(ix,jy,kz,lccna) = cccna(ix,kz)*mixconv + dninv = 1./dn(ix,kz) +! IF ( .not. present( qcw ) ) THEN ! Cloud droplets IF ( lnc > 1 ) THEN IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN - an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)/cwmas09 )*dn(ix,kz) + an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)*cwmasinv )*dn(ix,kz) + + IF ( invertccn_local ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + an(ix,jy,kz,lnc) + ELSE IF ( lccn > 1 .and. lccna < 1 ) THEN an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc) @@ -4361,6 +4534,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) IF ( lccna > 1 ) THEN an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) ENDIF + ENDIF ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. & ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN @@ -4500,9 +4674,56 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF ENDIF - + + +! ENDIF + +! spechum = qv_mp/(1.0_kind_phys+qv_mp) +! IF ( convertdry ) THEN +! qc = qc_mp/(1.0_kind_phys+qv_mp) + mixconvqv = 1 + IF ( present( spechum ) ) THEN ! convert back to "dry+vapor" mixing ratios + !an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconvqv = 1.0d0/(1.0d0 + an(ix,jy,kz,lv)) + spechum(ix,kz) = an(ix,jy,kz,lv)*mixconvqv + ELSE + mixconvqv = 1.0d0 + ENDIF + + IF ( present( qv ) ) qv(ix,kz) = an(ix,jy,kz,lv) + IF ( present( qcw ) ) qcw(ix,kz) = an(ix,jy,kz,lc)*mixconvqv + IF ( present( qrw ) ) qrw(ix,kz) = an(ix,jy,kz,lr)*mixconvqv + IF ( present( qci ) ) qci(ix,kz) = an(ix,jy,kz,li)*mixconvqv + IF ( present( qsw ) ) THEN + qsw(ix,kz) = an(ix,jy,kz,ls)*mixconvqv +! qsmax3 = Max( qsmax3, qsw(ix,kz) ) +! qsmax4 = Max( qsmax4, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) qhw(ix,kz) = an(ix,jy,kz,lh)*mixconvqv + IF ( lhl > 1 .and. present( qhl ) ) qhl(ix,kz) = an(ix,jy,kz,lhl)*mixconvqv + IF ( present( ccw ) ) ccw(ix,kz) = an(ix,jy,kz,lnc)*mixconvqv*dninv + IF ( present( crw ) ) crw(ix,kz) = an(ix,jy,kz,lnr)*mixconvqv*dninv + IF ( present( cci ) ) cci(ix,kz) = an(ix,jy,kz,lni)*mixconvqv*dninv + IF ( present( csw ) ) csw(ix,kz) = an(ix,jy,kz,lns)*mixconvqv*dninv + IF ( present( chw ) ) chw(ix,kz) = an(ix,jy,kz,lnh)*mixconvqv*dninv + IF ( lhl > 1 .and. present( chl ) ) chl(ix,kz) = an(ix,jy,kz,lnhl)*mixconvqv*dninv + IF ( lvh > 1 .and. present( vhw ) ) vhw(ix,kz) = an(ix,jy,kz,lvh)*mixconvqv + IF ( lvhl > 1 .and. present( vhl ) ) vhl(ix,kz) = an(ix,jy,kz,lvhl)*mixconvqv + IF ( lccn > 1 .and. present( cccn ) ) cccn(ix,kz) = an(ix,jy,kz,lccn)*mixconvqv*dninv + IF ( lccna > 1 .and. present( cccna ) ) cccna(ix,kz) = an(ix,jy,kz,lccna)*mixconvqv + + ENDDO ! ix ENDDO ! kz +! ELSE +! write(0,*) 'calcnfromq: lv = ',lv,lc,lr,li,ls,lh,lvh,lhl,lccn,lccna +! write(0,*) 'calcnfromq: nx,ny,nz,na = ',nx,ny,nz,na +! +! ENDIF + +! IF ( present( qsw ) ) THEN +! write(0,*) 'calcnfromq: qsmax = ',qsmax,qsmax2,qsmax3,qsmax4 +! ENDIF RETURN @@ -4710,7 +4931,9 @@ END subroutine calcnfromcuten SUBROUTINE calc_eff_radius & & (nx,ny,nz,na,jyslab & & ,nor,norz & - & ,t1,t2,t3 & + & ,t1,t2,t3,t4 & + & ,qcw,qci,qsw,qrw & + & ,ccw,cci,csw,crw & & ,an,dn ) implicit none @@ -4726,13 +4949,14 @@ SUBROUTINE calc_eff_radius & ! external temporary arrays ! - real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - + real,optional :: t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real, optional, dimension(nx,nz) :: qcw,qci,qsw,qrw,ccw,cci,csw,crw @@ -4768,8 +4992,9 @@ SUBROUTINE calc_eff_radius & real :: xdia(ngs,lc:lhab,3) real :: alpha(ngs,lc:lhab) - real :: gamc1,gamc2,gami1,gami2,gams1,gams2, factor_c, factor_i, factor_s - real :: lam_c, lam_i, lam_s + real :: gamc1,gamc2,gami1,gami2,gams1,gams2,gamr1,gamr2 + real :: factor_c, factor_i, factor_s, factor_r + real :: lam_c, lam_i, lam_s, lam_r integer :: il @@ -4796,11 +5021,21 @@ SUBROUTINE calc_eff_radius & gami2 = 1. ! Gamma[1 + alphac] gams1 = Gamma_sp(2. + snu) gams2 = Gamma_sp(1. + snu) + gamr1 = Gamma_sp(2. + rnu) + gamr2 = Gamma_sp(1. + rnu) factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu) factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu) factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu) + IF ( present(t4) ) THEN + IF ( imurain == 3 ) THEN + factor_r = (1. + rnu)*Gamma_sp(1. + rnu)/Gamma_sp(5./3. + rnu) + ELSE + factor_r = ((Pi*(alphar+3.)*(alphar+1.)*(alphar+1.))/6.)**(1./3.) + ENDIF + ENDIF + ! ! jy = 1 ! working on a 2d slab !! VERY IMPORTANT: SET jgs = jy @@ -4812,29 +5047,57 @@ SUBROUTINE calc_eff_radius & DO ix = 1,nx ! ixcol rho0(mgs) = dn(ix,jy,kz) + IF ( present( an ) ) THEN DO il = lc,ls qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) ENDDO + ELSE + qx(mgs,:) = 0.0 + cx(mgs,:) = 0.0 + IF ( present(qcw) ) qx(mgs,lc) = qcw(ix,kz) + IF ( present(qci) ) qx(mgs,li) = qci(ix,kz) + IF ( present(qsw) ) qx(mgs,ls) = qsw(ix,kz) + IF ( present(qrw) ) qx(mgs,lr) = qrw(ix,kz) + IF ( present(ccw) ) cx(mgs,lc) = ccw(ix,kz)*rho0(mgs) + IF ( present(cci) ) cx(mgs,li) = cci(ix,kz)*rho0(mgs) + IF ( present(csw) ) cx(mgs,ls) = csw(ix,kz)*rho0(mgs) + IF ( present(crw) ) cx(mgs,lr) = crw(ix,kz)*rho0(mgs) - IF ( qx(mgs,lc) > qxmin(lc) ) THEN + ENDIF + + IF ( present( t1 ) .and. qx(mgs,lc) > qxmin(lc) .and. cx(mgs,lc) > cxmin ) THEN ! Lambda for cloud droplets lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) t1(ix,jy,kz) = 0.5*factor_c/lam_c ENDIF - IF ( qx(mgs,li) > qxmin(li) ) THEN + IF ( present( t2 ) .and. qx(mgs,li) > qxmin(li) .and. cx(mgs,li) > cxmin ) THEN ! Lambda for cloud ice lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) t2(ix,jy,kz) = 0.5*factor_i/lam_i ENDIF - IF ( qx(mgs,ls) > qxmin(ls) ) THEN + IF ( present( t3 ) .and. qx(mgs,ls) > qxmin(ls) .and. cx(mgs,ls) > cxmin ) THEN ! Lambda for snow lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.) t3(ix,jy,kz) = 0.5*factor_s/lam_s ENDIF + IF ( present( t4 ) .and. present(qrw) .and. present(crw) ) THEN + IF ( qx(mgs,lr) > Max(1.e-8,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN + IF ( imurain == 1 ) THEN ! gamma-diameter +! Lambda for rain + lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.) + t4(ix,jy,kz) = 0.5*(alphar+3.)/lam_r + ELSE ! gamma-volume +! Lambda for rain + lam_r = ((cx(mgs,lr)*(Pi/6.)*xdn0(lr)*Gamr1)/(qx(mgs,lr)*rho0(mgs)*Gamr2))**(1./3.) + t4(ix,jy,kz) = 0.5*factor_r/lam_r + ENDIF + ENDIF + ENDIF + ENDDO ! ix ENDDO ! kz @@ -5009,7 +5272,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & - & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + & itype1a,itype2a,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) implicit none @@ -5047,8 +5311,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & integer, intent (in) :: itype1a,itype2a,infdo integer, intent (in) :: ildo ! which species to do, or all if ildo=0 - real :: axh(ngs),bxh(ngs) - real :: axhl(ngs),bxhl(ngs) + real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) +!! real :: axh(ngs),bxh(ngs) +! real :: axhl(ngs),bxhl(ngs) ! Local vars @@ -5955,17 +6220,17 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) ) IF ( indxr < ngdnmm ) THEN - axh(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) - bxh(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + axx(mgs,lh) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxx(mgs,lh) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) ELSE - axh(mgs) = mmgraupvt(indxr,2) - bxh(mgs) = mmgraupvt(indxr,3) + axx(mgs,lh) = mmgraupvt(indxr,2) + bxx(mgs,lh) = mmgraupvt(indxr,3) ENDIF - aax = axh(mgs) - bbx = bxh(mgs) + aax = axx(mgs,lh) + bbx = bxx(mgs,lh) cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) @@ -5979,12 +6244,12 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & cdxgs(mgs,lh) = cd IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN -! axh(mgs) = (gf4p5/6.0)* & +! axx(mgs,lh) = (gf4p5/6.0)* & ! & Sqrt( (xdn(mgs,lh)*4.0*gr) / & ! & (3.0*cd*rho0(mgs)) ) - axh(mgs) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) - bxh(mgs) = 0.5 - vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axh(mgs) * Sqrt(xdia(mgs,lh,1)) + axx(mgs,lh) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + bxx(mgs,lh) = 0.5 + vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lh) * Sqrt(xdia(mgs,lh,1)) ! vtxbar(mgs,lh,1) = (gf4p5/6.0)* & ! & Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) / & ! & (3.0*cd*rho0(mgs)) ) @@ -6006,13 +6271,13 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & IF ( icdx > 0 .and. icdx /= 6) THEN aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) vtxbar(mgs,lh,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y - axh(mgs) = aax - bxh(mgs) = bbx + axx(mgs,lh) = aax + bxx(mgs,lh) = bbx ELSEIF (icdx == 6 ) THEN vtxbar(mgs,lh,1) = rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y ELSE ! icdx < 0 - axh(mgs) = ax(lh) - bxh(mgs) = bx(lh) + axx(mgs,lh) = ax(lh) + bxx(mgs,lh) = bx(lh) vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y ENDIF @@ -6059,17 +6324,17 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) ) IF ( indxr < ngdnmm ) THEN - axhl(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) - bxhl(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + axx(mgs,lhl) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxx(mgs,lhl) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) ELSE - axhl(mgs) = mmgraupvt(indxr,2) - bxhl(mgs) = mmgraupvt(indxr,3) + axx(mgs,lhl) = mmgraupvt(indxr,2) + bxx(mgs,lhl) = mmgraupvt(indxr,3) ENDIF - aax = axhl(mgs) - bbx = bxhl(mgs) + aax = axx(mgs,lhl) + bbx = bxx(mgs,lhl) cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) @@ -6083,12 +6348,12 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & cdxgs(mgs,lhl) = cd IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 .and. icdxhl /= 6) THEN -! axhl(mgs) = (gf4p5/6.0)* & +! axx(mgs,lhl) = (gf4p5/6.0)* & ! & Sqrt( (xdn(mgs,lhl)*4.0*gr) / & ! & (3.0*cd*rho0(mgs)) ) - axhl(mgs) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) - bxhl(mgs) = 0.5 - vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axhl(mgs) * Sqrt(xdia(mgs,lhl,1)) + axx(mgs,lhl) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + bxx(mgs,lhl) = 0.5 + vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lhl) * Sqrt(xdia(mgs,lhl,1)) ELSE IF ( icdxhl /= 6 ) bbx = bx(lhl) tmp = 4. + alpha(mgs,lhl) + bbx @@ -6104,13 +6369,13 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & IF ( icdxhl > 0 .and. icdxhl /= 6) THEN aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y - axhl(mgs) = aax - bxhl(mgs) = bbx + axx(mgs,lhl) = aax + bxx(mgs,lhl) = bbx ELSEIF ( icdxhl == 6 ) THEN vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y ELSE - axhl(mgs) = ax(lhl) - bxhl(mgs) = bx(lhl) + axx(mgs,lhl) = ax(lhl) + bxx(mgs,lhl) = bx(lhl) vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y ENDIF @@ -6176,8 +6441,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSEIF ( icdx .eq. 5 ) THEN cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) - aax = axh(mgs) - bbx = bxh(mgs) + aax = axx(mgs,lh) + bbx = bxx(mgs,lh) ELSEIF ( icdx <= 0 ) THEN ! aax = ax(lh) bbx = bx(lh) @@ -6198,8 +6463,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) - aax = axhl(mgs) - bbx = bxhl(mgs) + aax = axx(mgs,lhl) + bbx = bxx(mgs,lhl) ENDIF ENDIF ! } @@ -6355,7 +6620,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,lh,1) = graupelfallfac*vtxbar(mgs,lh,1) vtxbar(mgs,lh,2) = graupelfallfac*vtxbar(mgs,lh,2) vtxbar(mgs,lh,3) = graupelfallfac*vtxbar(mgs,lh,3) - axh(mgs) = graupelfallfac*axh(mgs) + axx(mgs,lh) = graupelfallfac*axx(mgs,lh) ENDDO ENDIF @@ -6364,7 +6629,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,lhl,1) = hailfallfac*vtxbar(mgs,lhl,1) vtxbar(mgs,lhl,2) = hailfallfac*vtxbar(mgs,lhl,2) vtxbar(mgs,lhl,3) = hailfallfac*vtxbar(mgs,lhl,3) - axhl(mgs) = hailfallfac*axhl(mgs) + axx(mgs,lhl) = hailfallfac*axx(mgs,lhl) ENDDO ENDIF @@ -6454,7 +6719,8 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & real :: zx(ngs,lr:lhab) real xdnmx(lc:lhab), xdnmn(lc:lhab) - real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + real :: axx(ngs,lh:lhab), bxx(ngs,lh:lhab) +! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) ! ! drag coefficients @@ -6799,7 +7065,8 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) @@ -7518,13 +7785,25 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN - IF ( .true. ) THEN -! IF ( qxw > qsmin ) THEN ! old version + ! IF ( .true. ) THEN + IF ( qxw > qsmin ) THEN ! old version ! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & ! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size + ! p = 0.106214 for m = p v^(2/3) + dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) + IF ( .true. .or. dnsnow < 900. ) THEN + gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + & + & (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ & + & (an(ix,jy,kz,lns)*(917.)**2* gsnow1*(1.0+snu)**(4./3.)) + ELSE ! otherwise small enough to assume ice spheres? + gtmp(ix,kz) = (36./pi**2) * 1.e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + ENDIF + ENDIF ENDIF @@ -7889,6 +8168,7 @@ SUBROUTINE NUCOND & & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & + & ,thproc,numproc, dx1,dy1,gz & & ,axtra,io_flag & & ,ssfilt,t00,t77,flag_qndrop & & ) @@ -7943,6 +8223,9 @@ SUBROUTINE NUCOND & ! local + integer, intent(in) :: numproc + real, intent(inout) :: thproc(nz,numproc) + real, intent(in) :: dx1,dy1, gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) logical :: io_flag @@ -8561,13 +8844,22 @@ SUBROUTINE NUCOND & IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) - qx(mgs,lc)*rho0(mgs)*dv/dtp ! evaporation rate + ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp ENDIF qx(mgs,lc) = 0. IF ( restoreccn ) THEN IF ( irenuc <= 2 ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ENDIF ENDIF IF ( lccna > 1 ) THEN ccna(mgs) = ccna(mgs) - cx(mgs,lc) @@ -8581,7 +8873,13 @@ SUBROUTINE NUCOND & IF ( qx(mgs,lc) .le. 0. ) THEN IF ( restoreccn ) THEN IF ( irenuc <= 2 ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) +! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) +! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ENDIF ENDIF IF ( lccna > 1 ) THEN ccna(mgs) = ccna(mgs) - cx(mgs,lc) @@ -8592,7 +8890,13 @@ SUBROUTINE NUCOND & tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size IF ( restoreccn ) THEN IF ( irenuc <= 2 ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) +! ccnc(mgs) = ccnc(mgs) + tmp + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + tmp + ENDIF ENDIF IF ( lccna > 1 ) THEN ccna(mgs) = ccna(mgs) - tmp @@ -8601,6 +8905,11 @@ SUBROUTINE NUCOND & cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) - felv(mgs)*QEVAP/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) - QEVAP*rho0(mgs)*dv/dtp ! evaporation rate + ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp ENDIF @@ -8871,6 +9180,11 @@ SUBROUTINE NUCOND & IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) ENDIF + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + e1*(DCLOUD + dqr)*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + (DCLOUD + dqr)*rho0(mgs)*dv/dtp ! condensation rate + ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp @@ -8938,6 +9252,11 @@ SUBROUTINE NUCOND & thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate + ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp ENDIF @@ -9195,6 +9514,11 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate + ENDIF ENDIF ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air @@ -9301,6 +9625,11 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate + ENDIF ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) ENDIF @@ -9359,6 +9688,11 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate + ENDIF ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ENDIF @@ -9406,6 +9740,11 @@ SUBROUTINE NUCOND & IF ( qvex .gt. 0.0 ) THEN thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*qvex/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + qvex*rho0(mgs)*dv/dtp ! condensation rate + ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp ENDIF @@ -9582,6 +9921,8 @@ SUBROUTINE NUCOND & ! ! Redistribution everywhere in the domain... ! + IF ( .true. ) THEN + frac = 1.0 ! 0.25 ! 1.0 ! 0.2 ! ! alternate test version for ipconc .ge. 3 @@ -9629,6 +9970,10 @@ SUBROUTINE NUCOND & IF ( lhlw .gt. 1 ) THEN an(ix,jy,kz,lhlw) = 0.0 ENDIF + + IF ( lnhlf .gt. 1 ) THEN + an(ix,jy,kz,lnhlf) = 0.0 + ENDIF IF ( lzhl .gt. 1 ) THEN an(ix,jy,kz,lzhl) = 0.0 @@ -9702,9 +10047,9 @@ SUBROUTINE NUCOND & end if + ENDIF !lhl - ENDIF !lhl if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then @@ -9725,6 +10070,10 @@ SUBROUTINE NUCOND & IF ( lhw .gt. 1 ) THEN an(ix,jy,kz,lhw) = 0.0 ENDIF + + IF ( lnhf .gt. 1 ) THEN + an(ix,jy,kz,lnhf) = 0.0 + ENDIF IF ( lzh .gt. 1 ) THEN an(ix,jy,kz,lzh) = 0.0 @@ -9942,7 +10291,7 @@ SUBROUTINE NUCOND & ! write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst) ! write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) ! ENDIF - IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) ) THEN + IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN ! an(ix,jy,kz,lccn) = & ! an(ix,jy,kz,lccn) + Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst)) ! Equivalent form after expanding last term: @@ -9960,6 +10309,7 @@ SUBROUTINE NUCOND & ! end do end do + ENDIF ! true/false IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' ! @@ -9996,8 +10346,10 @@ subroutine nssl_2mom_gs & ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,tmp3d,tkediss & + & ,thproc,numproc,dx1,dy1 & & ,timevtcalc,axtra,io_flag & - & ,rainprod2d, evapprod2d & + & , has_wetscav,rainprod2d, evapprod2d & + & ,errmsg,errflg & & ,elec,its,ids,ide,jds,jde & & ) @@ -10077,6 +10429,10 @@ subroutine nssl_2mom_gs & integer nxend,nyend,nzend,nzbeg integer :: my_rank = 0 integer, parameter :: myprock = 1, nprock = 1 + logical, intent(in) :: has_wetscav + integer, intent(in) :: numproc + real, intent(inout) :: thproc(nz,numproc) + real, intent(in) :: dx1,dy1 real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) @@ -10092,6 +10448,7 @@ subroutine nssl_2mom_gs & integer iraincv, icgxconv parameter ( iraincv = 1, icgxconv = 1) real ffrz + real :: ffrzh = 1.0 real qcitmp,cirdiatmp ! ,qiptmp,qirtmp real ccwtmp,ccitmp ! ,ciptmp,cirtmp @@ -10101,7 +10458,7 @@ subroutine nssl_2mom_gs & double precision dp1 - double precision frac, frach, xvfrz + double precision frac, frach, xvfrz, xvbiggsnow double precision :: timevtcalc double precision :: dpt1,dpt2 @@ -10115,7 +10472,9 @@ subroutine nssl_2mom_gs & logical, parameter :: usegamxinf3 = .false. ! real rar ! rime accretion rate as calculated from qxacw - + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg ! a few vars for time-split fallout real vtmax integer n,ndfall @@ -10336,7 +10695,7 @@ subroutine nssl_2mom_gs & real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia,rmas real :: snowmeltmass = 0 - real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain +! real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain real, parameter :: rimedens = 500. ! default rime density ! real svc(ngs) ! droplet volume @@ -10380,7 +10739,7 @@ subroutine nssl_2mom_gs & real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn parameter ( rwradmn = 50.e-6 ) real dh0 - real dg0(ngs) + real dg0(ngs),df0(ngs) real clionpmx,clionnmx parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 @@ -10415,21 +10774,25 @@ subroutine nssl_2mom_gs & real :: gfm1(ngs),gfm2(ngs) real :: hfm1(ngs),hfm2(ngs) - logical :: wetsfc(ngs),wetsfchl(ngs) - logical :: wetgrowth(ngs), wetgrowthhl(ngs) + logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs) + logical :: wetgrowth(ngs), wetgrowthhl(ngs), wetgrowthf(ngs) real qitmp(ngs),qistmp(ngs) - real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs) - real rzxs(ngs) - real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs),cdh(ngs),cdhl(ngs) + real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs), rzxhlf(ngs) + real rzxs(ngs), rzxf(ngs) +! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + real cdh(ngs),cdhl(ngs) + real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) real vt2ave(ngs) real :: qcwresv(ngs), ccwresv(ngs) ! "reserved" droplet mass and number that are too small for accretion + real :: lfsave(ngs,6) real :: qx(ngs,lv:lhab) real :: qxw(ngs,ls:lhab) real :: qxwlg(ngs,lh:lhab) + real :: chxf(ngs,lh:lhab) real :: cx(ngs,lc:lhab) real :: cxmxd(ngs,lc:lhab) real :: qxmxd(ngs,lv:lhab) @@ -10446,8 +10809,8 @@ subroutine nssl_2mom_gs & real :: rimdn(ngs,li:lhab) real :: raindn(ngs,li:lhab) real :: alpha(ngs,lc:lhab) - real :: dab0lh(ngs,lc:lhab,lr:lhab) - real :: dab1lh(ngs,lc:lhab,lr:lhab) + real :: dab0lh(ngs,lc:lhab,lc:lhab) + real :: dab1lh(ngs,lc:lhab,lc:lhab) real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis real :: qsimxsub(ngs) ! max depositionof qi+qs+qis @@ -10550,7 +10913,7 @@ subroutine nssl_2mom_gs & real csaci(ngs), csacs(ngs) real cracw(ngs) real chacw(ngs), chacr(ngs) - real :: chlacw(ngs) ! = 0.0 + real :: chlacw(ngs) real chaci(ngs), chacs(ngs) ! real :: chlacr(ngs) @@ -10577,6 +10940,7 @@ subroutine nssl_2mom_gs & real crcev(ngs) real crshr(ngs) + real cwshw(ngs), qwshw(ngs) ! ! ! arrays for w-ac-x ; x-ac-w @@ -10592,9 +10956,10 @@ subroutine nssl_2mom_gs & real qsacw(ngs) ! ,qwacs(ngs), real qhacw(ngs) ! qwach(ngs), - real :: qhlacw(ngs) ! = 0.0 + real :: qhlacw(ngs) ! real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + real qfmul1(ngs),cfmul1(ngs) ! real qsacws(ngs) @@ -10610,7 +10975,7 @@ subroutine nssl_2mom_gs & real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) - real :: qhlacr(ngs),qhlacrmlr(ngs) ! = 0.0 + real :: qhlacr(ngs),qhlacrmlr(ngs) real qsacrs(ngs) !,qracss(ngs) ! ! ice - ice interactions @@ -10620,30 +10985,30 @@ subroutine nssl_2mom_gs & real qhaci(ngs) real qhacs(ngs) - real :: qhacis(ngs) = 0.0 - real :: chacis(ngs) = 0.0 - real :: chacis0(ngs) = 0.0 + real :: qhacis(ngs) + real :: chacis(ngs) + real :: chacis0(ngs) real :: csaci0(ngs) ! collision rate only real :: chaci0(ngs) ! collision rate only real :: chacs0(ngs) ! collision rate only - real :: chlaci0(ngs) ! = 0.0 - real :: chlacis(ngs) = 0.0 - real :: chlacis0(ngs) = 0.0 - real :: chlacs0(ngs) ! = 0.0 + real :: chlaci0(ngs) + real :: chlacis(ngs) + real :: chlacis0(ngs) + real :: chlacs0(ngs) real :: qsaci0(ngs) ! collision rate only real :: qsacis0(ngs) ! collision rate only real :: qhaci0(ngs) ! collision rate only real :: qhacis0(ngs) ! collision rate only real :: qhacs0(ngs) ! collision rate only - real :: qhlaci0(ngs) ! = 0.0 - real :: qhlacis0(ngs) ! = 0.0 - real :: qhlacs0(ngs) ! = 0.0 + real :: qhlaci0(ngs) + real :: qhlacis0(ngs) + real :: qhlacs0(ngs) - real :: qhlaci(ngs) ! = 0.0 - real :: qhlacis(ngs) ! = 0.0 - real :: qhlacs(ngs) ! = 0.0 + real :: qhlaci(ngs) + real :: qhlacis(ngs) + real :: qhlacs(ngs) ! ! conversions ! @@ -10652,11 +11017,13 @@ subroutine nssl_2mom_gs & real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) real zhacw(ngs), zhacs(ngs), zhaci(ngs) real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs) + real zfacw(ngs), zfacs(ngs), zfaci(ngs) + real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs) real zhmlrtmp,zhmlr0inf,zhlmlr0inf - real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs) + real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs) real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) real zhcns(ngs), zhcni(ngs) - real zhwdn(ngs) ! change in Z due to density changes + real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes real zhldn(ngs) ! change in Z due to density changes real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs) @@ -10692,10 +11059,6 @@ subroutine nssl_2mom_gs & real qismlr(ngs) ! - real qfdpv(ngs),qfsbv(ngs) ! qfcnv(ngs),qfevv(ngs), - real qfmlr(ngs),qfdsv(ngs) ! ,qfcev(ngs) - real qfwet(ngs),qfdry(ngs),qfshr(ngs) - real qfshrp(ngs) ! real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) @@ -10719,7 +11082,7 @@ subroutine nssl_2mom_gs & real qhlcevlg(ngs), chlcevlg(ngs) real qhcevlg(ngs), chcevlg(ngs) - real vhfzh(ngs) ! change in volume from water that freezes on mixed-phase graupel + real vhfzh(ngs), vffzf(ngs) ! change in volume from water that freezes on mixed-phase graupel, frozen drops real vhlfzhl(ngs) ! change in volume from water that freezes on mixed-phase hail real vhshdr(ngs) !accreted water that leaves on graupel (mixedphase) @@ -10728,6 +11091,7 @@ subroutine nssl_2mom_gs & real vhlmlr(ngs) !melt water that leaves hail (single phase) real vhsoak(ngs) ! aquired water that seeps into graupel. real vhlsoak(ngs) ! aquired water that seeps into hail. + ! real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs), real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs) @@ -10759,10 +11123,10 @@ subroutine nssl_2mom_gs & real qrztot(ngs),qrzmax(ngs),qrzfac(ngs) real qrcev(ngs) real qrshr(ngs) - real fsw(ngs),fhw(ngs),fhlw(ngs) !liquid water fractions + real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions real qhcnf(ngs) - real :: qhlcnh(ngs) ! = 0.0 + real :: qhlcnh(ngs) real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel @@ -10772,17 +11136,19 @@ subroutine nssl_2mom_gs & real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) real ehxr(ngs),ehlr(ngs),egmr(ngs) - real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs) + real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) real ehscnv(ngs) real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) + real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs) real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs) real esiclsn(ngs) real :: ehs_collsn = 0.5, ehi_collsn = 1.0 + real :: efs_collsn = 0.5, efi_collsn = 1.0 real :: ehls_collsn = 1.0, ehli_collsn = 1.0 real :: esi_collsn = 1.0 @@ -10790,7 +11156,7 @@ subroutine nssl_2mom_gs & real cwr(8,2) ! radius and inverse of interval data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & ! radius & 1.0, 1.0, 0.5, 0.5, 0.5, 0.2, 0.2, 1. / ! inverse of interval - integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs) + integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs), ifwr(ngs) real grad(6,2) ! graupel radius and inverse of interval data grad / 100., 200., 300., 400., 600., 1000., & & 1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1. / @@ -10805,9 +11171,12 @@ subroutine nssl_2mom_gs & ! : 0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400 - real da0lr(ngs) + real da0lr(ngs),da1lr(ngs) + real da0lc(ngs),da1lc(ngs) real da0lh(ngs) real da0lhl(ngs) + real da0lf(ngs) + real :: da0lx(ngs,lr:lhab) real va0 (lc:lqmx) ! collection coefficients from Seifert 2005 real vab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 @@ -10836,6 +11205,7 @@ subroutine nssl_2mom_gs & real pvhwi(ngs), pvhwd(ngs) + real pvfwi(ngs), pvfwd(ngs) real pvhli(ngs), pvhld(ngs) real pvswi(ngs), pvswd(ngs) ! @@ -10866,6 +11236,7 @@ subroutine nssl_2mom_gs & real pzrwi(ngs), pzrwd(ngs) real pzhwi(ngs), pzhwd(ngs) + real pzfwi(ngs), pzfwd(ngs) real pzhli(ngs), pzhld(ngs) real pzswi(ngs), pzswd(ngs) @@ -10939,14 +11310,16 @@ subroutine nssl_2mom_gs & ! ! Miscellaneous variables ! + real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. + real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh integer lqrw real vt real arg ! gamma is a function real erbnd1, fdgt1, costhe1 real qeps - real dyi2,dzi2,cp608,bta1,cnit,dragh,dnz00,pii - real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds,gr + real dyi2,dzi2,bta1,cnit,dragh,dnz00,pii ! ,cp608 + real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds real gf1palp(ngs) ! for storing Gamma[1.0 + alphar] @@ -11077,6 +11450,7 @@ subroutine nssl_2mom_gs & ENDDO + ffrzh = 1 ! DO il = lc,lhab ! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) ! ENDDO @@ -11108,7 +11482,7 @@ subroutine nssl_2mom_gs & ! constants ! - cp608 = 0.608 +! cp608 = 0.608 aradcw = -0.27544 bradcw = 0.26249e+06 cradcw = -1.8896e+10 @@ -11139,7 +11513,7 @@ subroutine nssl_2mom_gs & gf4p5 = 11.63172839656745 ! gamma(4.0+0.5) gf3ds = 3.0458730354120997 ! gamma(3.0+ds) gf1ds = 0.8863557896089221 ! gamma(1.0+ds) - gr = 9.8 + gf43rds = 0.8929795116 ! gamma(4./3.) gf53rds = 0.9027452930 ! gamma(5./3.) gf73rds = 1.190639349 ! gamma(7./3.) @@ -11250,6 +11624,12 @@ subroutine nssl_2mom_gs & rwmasn = xvmn(lr)*1000. rwmasx = xvmx(lr)*1000. + IF ( biggsnowdiam > 0.0 ) THEN + xvbiggsnow = (pi/6.0)*biggsnowdiam**3 + ELSE + xvbiggsnow = xvmn(lh) + ENDIF + ! ! ci constants in mks units ! @@ -11354,6 +11734,8 @@ subroutine nssl_2mom_gs & IF ( lhl > 1 ) THEN IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) ishail = .true. ENDIF + + if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & @@ -11373,8 +11755,8 @@ subroutine nssl_2mom_gs & if ( ngscnt .eq. 0 ) go to 9998 - if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5' - + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5, ngscnt = ',ngscnt + ! write(0,*) 'allocating qc' @@ -11384,6 +11766,7 @@ subroutine nssl_2mom_gs & xdia(:,:,:) = 0.0 raindn(:,:) = 900. cx(:,:) = 0.0 + IF ( lnhf > 1 .or. lnhlf > 1 ) chxf(:,:) = 0.0 alpha(:,:) = 0.0 DO il = li,lhab DO mgs = 1,ngscnt @@ -11393,6 +11776,7 @@ subroutine nssl_2mom_gs & ! ! define temporaries for state variables to be used in calculations ! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = def temps' do mgs = 1,ngscnt kgsm(mgs) = max(kgs(mgs)-1,1) kgsp(mgs) = min(kgs(mgs)+1,nz-1) @@ -11479,20 +11863,30 @@ subroutine nssl_2mom_gs & alpha(:,ls) = xnu(ls) ENDIF - DO il = lc,lhab + DO il = lr,lhab do mgs = 1,ngscnt IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) - DO ic = lr,lhab - dab0lh(mgs,il,ic) = dab0(ic,il) - dab1lh(mgs,il,ic) = dab1(ic,il) + + + DO ic = lc,lhab + dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) ENDDO ENDDO end do ! DO mgs = 1,ngscnt + DO il = lr,lhab + da0lx(:,il) = da0(il) + ENDDO da0lh(:) = da0(lh) da0lr(:) = da0(lr) + da1lr(:) = da1(lr) + da0lc(:) = da0(lc) + da1lc(:) = da1(lc) + + IF ( lzh < 1 .or. lzhl < 1 ) THEN rzxhlh(:) = rzhl/rz ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN @@ -11529,6 +11923,7 @@ subroutine nssl_2mom_gs & ! ssmax = 0.0 + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b' if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt @@ -11626,7 +12021,11 @@ subroutine nssl_2mom_gs & ENDIF ENDIF ENDIF + + end do + + end if if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then @@ -11649,6 +12048,8 @@ subroutine nssl_2mom_gs & ENDIF ENDIF ENDIF + + end do end if @@ -11832,6 +12233,7 @@ subroutine nssl_2mom_gs & ENDIF ENDIF + IF ( lhl .gt. 1 ) THEN xdn(mgs,lhl) = xdn0(lhl) @@ -11924,7 +12326,8 @@ subroutine nssl_2mom_gs & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & & ipconc,ndebug,ngs,nz,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) + & itype1,itype2,temcg,infdo,alpha,0,axx,bxx) ! ,cdh,cdhl) +! & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) IF ( lwsm6 .and. ipconc == 0 ) THEN @@ -11986,7 +12389,7 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 2 ) THEN DO mgs = 1,ngscnt - rb(mgs) = 0.5*xdia(mgs,lc,1)*((1./(1.+alpha(mgs,lc))))**(1./6.) + rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.) xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) IF ( rb(mgs) .gt. 3.51e-6 ) THEN @@ -12111,7 +12514,7 @@ subroutine nssl_2mom_gs & DO mgs = 1,ngscnt - DO il = lh,lhab ! graupel and hail only + DO il = lh,lhab ! graupel and hail only (and frozen drops) vshdgs(mgs,il) = vshd ! base value @@ -12152,6 +12555,7 @@ subroutine nssl_2mom_gs & erw(mgs) = 0.0 esw(mgs) = 0.0 ehw(mgs) = 0.0 + efw(mgs) = 0.0 ehlw(mgs) = 0.0 ! ehxw(mgs) = 0.0 ! @@ -12237,6 +12641,7 @@ subroutine nssl_2mom_gs & ENDDO ENDIF + IF ( lhl .gt. 1 ) THEN ! hail is turned on ihlr(mgs) = 1 IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN @@ -12530,6 +12935,7 @@ subroutine nssl_2mom_gs & ENDIF ! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density +! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density ehs(mgs) = Min(ehs(mgs),ehsmax) IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0 end if @@ -12551,7 +12957,7 @@ subroutine nssl_2mom_gs & end if ENDIF - + ! ! ! Hail: Collection (cxc) efficiencies @@ -12682,6 +13088,8 @@ subroutine nssl_2mom_gs & ! end if ! end do + + ! ! ! @@ -12873,7 +13281,7 @@ subroutine nssl_2mom_gs & qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt* & & ( da0(ls)*xdia(mgs,ls,3)**2 + & & dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) ) csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc) ENDIF @@ -12959,6 +13367,7 @@ subroutine nssl_2mom_gs & ! ! ! + if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' ! do mgs = 1,ngscnt @@ -12990,8 +13399,8 @@ subroutine nssl_2mom_gs & qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,lc,lh)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) + & dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) ENDIF qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) @@ -13042,10 +13451,10 @@ subroutine nssl_2mom_gs & rimdn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) ! IF ( igs(mgs) == 30 ) THEN -! write(0,*) 'k,vt: ',kgs(mgs),vt, vtxbar(mgs,lh,1),vtxbar(mgs,lh,2), rhovt(mgs)*axh(mgs)*( (alpha(mgs,lh)+3.)*xdia(mgs,lh,1) )**bxh(mgs) +! write(0,*) 'k,vt: ',kgs(mgs),vt, vtxbar(mgs,lh,1),vtxbar(mgs,lh,2), rhovt(mgs)*axx(mgs,lh)*( (alpha(mgs,lh)+3.)*xdia(mgs,lh,1) )**bxx(mgs,lh) ! write(0,*) 'diam: char, mean, maxmass = ',xdia(mgs,lh,1),xdia(mgs,lh,3),(alpha(mgs,lh)+3.)*xdia(mgs,lh,1) -! write(0,*) 'ax,bx,cd,xdn = ',axh(mgs),bxh(mgs),cdxgs(mgs,lh),xdn(mgs,lh) -! write(0,*) 'vt_char,vt_mean = ',rhovt(mgs)*axh(mgs)*( xdia(mgs,lh,1) )**bxh(mgs),rhovt(mgs)*axh(mgs)*( xdia(mgs,lh,3) )**bxh(mgs) +! write(0,*) 'ax,bx,cd,xdn = ',axx(mgs,lh),bxx(mgs,lh),cdxgs(mgs,lh),xdn(mgs,lh) +! write(0,*) 'vt_char,vt_mean = ',rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,1) )**bxx(mgs,lh),rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,3) )**bxx(mgs,lh) ! write(0,*) 'rimdn,alpha = ',rimdn(mgs,lh),alpha(mgs,lh) ! ENDIF @@ -13096,7 +13505,7 @@ subroutine nssl_2mom_gs & qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da1(li)*xdia(mgs,li,3)**2 ) qhaci(mgs) = Min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) ) ELSE @@ -13124,7 +13533,7 @@ subroutine nssl_2mom_gs & qhacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*qx(mgs,lis)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,lis,lh)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & dab1lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & & da1(li)*xdia(mgs,lis,3)**2 ) qhacis(mgs) = Min( ehis(mgs)*qhacis0(mgs), qxmxd(mgs,lis) ) ENDIF @@ -13144,7 +13553,7 @@ subroutine nssl_2mom_gs & qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & & da1(ls)*xdia(mgs,ls,3)**2 ) qhacs(mgs) = Min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) ) @@ -13182,8 +13591,9 @@ subroutine nssl_2mom_gs & qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,lr,lh)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & - & da1(lr)*xdia(mgs,lr,3)**2 ) + & dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da1lr(mgs)*xdia(mgs,lr,3)**2 ) +! & da1(lr)*xdia(mgs,lr,3)**2 ) ! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp !! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) !! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) @@ -13209,14 +13619,14 @@ subroutine nssl_2mom_gs & ! : 1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) + ! : 2.*xdia(mgs,lh,2)) -! chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* -! : ( da0lh(mgs)*xdia(mgs,lh,3)**2 + -! : dab0lh(mgs,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + -! : da0(lr)*xdia(mgs,lr,3)**2 ) + chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da0lr(mgs)*xdia(mgs,lr,3)**2 ) ! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp - chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) chacr(mgs) = min(chacr(mgs),crmxd(mgs)) IF ( lzh .gt. 1 ) THEN @@ -13300,8 +13710,8 @@ subroutine nssl_2mom_gs & qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,lc,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) + & dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) @@ -13361,7 +13771,7 @@ subroutine nssl_2mom_gs & qhlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,li,lhl)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & & da1(li)*xdia(mgs,li,3)**2 ) ! qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) ) qhlaci(mgs) = Min( ehli(mgs)*qhlaci0(mgs), qimxd(mgs) ) @@ -13382,7 +13792,7 @@ subroutine nssl_2mom_gs & qhlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,ls,lhl)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & & da1(ls)*xdia(mgs,ls,3)**2 ) qhlacs(mgs) = Min( ehls(mgs)*qhlacs0(mgs), qsmxd(mgs) ) @@ -13406,8 +13816,9 @@ subroutine nssl_2mom_gs & qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,lr,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & - & da1(lr)*xdia(mgs,lr,3)**2 ) + & dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da1lr(mgs)*xdia(mgs,lr,3)**2 ) +! & da1(lr)*xdia(mgs,lr,3)**2 ) ! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp !! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) !! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) @@ -13426,8 +13837,8 @@ subroutine nssl_2mom_gs & ELSE chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab0(lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & - & da0(lr)*xdia(mgs,lr,3)**2 ) + & dab0lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da0lr(mgs)*xdia(mgs,lr,3)**2 ) chlacr(mgs) = min(chlacr(mgs),crmxd(mgs)) @@ -13459,7 +13870,7 @@ subroutine nssl_2mom_gs & qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & & dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) ) ENDIF @@ -13534,7 +13945,7 @@ subroutine nssl_2mom_gs & qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & - & dab1lh(mgs,lr,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & dab1lh(mgs,li,lr)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da1(lr)*xdia(mgs,lr,3)**2 ) qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) @@ -13542,7 +13953,7 @@ subroutine nssl_2mom_gs & ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & - & dab0lh(mgs,lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & + & dab0lh(mgs,li,lr)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & & da0(lr)*xdia(mgs,lr,3)**2 ) ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) @@ -13640,7 +14051,7 @@ subroutine nssl_2mom_gs & IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN IF ( ciacr(mgs) > qxmin(lh) ) THEN xvfrz = rho0(mgs)*qiacr(mgs)/(ciacr(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density - frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) qiacrs(mgs) = (1.-frach)*qiacr(mgs) ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) @@ -13783,6 +14194,7 @@ subroutine nssl_2mom_gs & ! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) end do end if + ! ! ! @@ -13841,7 +14253,7 @@ subroutine nssl_2mom_gs & chaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab0lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & dab0lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da0(li)*xdia(mgs,li,3)**2 ) ELSE @@ -13869,7 +14281,7 @@ subroutine nssl_2mom_gs & chacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*cx(mgs,lis)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab0lh(mgs,lis,lh)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & dab0lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & & da0(lis)*xdia(mgs,lis,3)**2 ) @@ -13891,7 +14303,7 @@ subroutine nssl_2mom_gs & chacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab0lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & dab0lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & & da0(ls)*xdia(mgs,ls,3)**2 ) ELSE @@ -14050,11 +14462,12 @@ subroutine nssl_2mom_gs & cautn(mgs) = 0.0 ENDDO + IF ( dmrauto >= -1 ) THEN !{ DO mgs = 1,ngscnt ! qracw(mgs) = 0.0 ! cracw(mgs) = 0.0 IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN - ! .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing + !( .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing volb = xv(mgs,lc)*(1./(1.+alpha(mgs,lc)))**(1./2.) cautn(mgs) = Min(ccmxd(mgs), & & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) @@ -14151,6 +14564,8 @@ subroutine nssl_2mom_gs & ENDIF ENDDO + + ENDIF !} dmrauto >= 0 @@ -14325,19 +14740,21 @@ subroutine nssl_2mom_gs & crfrz(mgs) = 0.0 qrfrz(mgs) = 0.0 + qrfrzf(mgs) = 0.0 ELSE !{ IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN +! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 crfrzs(mgs) = crfrz(mgs) qrfrzs(mgs) = qrfrz(mgs) - ELSEIF ( dbigg < Max(dfrz,dhmn) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals + ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! crfrzs(mgs) = crfrz(mgs) @@ -15042,17 +15459,17 @@ subroutine nssl_2mom_gs & del = tmp - dgam*i g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - tmp = 2.5 + alpha(mgs,lh) + 0.5*bxh(mgs) + tmp = 2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh) i = Int(dgami*(tmp)) del = tmp - dgam*i y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp - hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxh(mgs)))*Sqrt(axh(mgs)*rhovt(mgs)) + hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))*Sqrt(axx(mgs,lh)*rhovt(mgs)) hwvent(mgs) = & & ( 0.78*x + y*hwventy(mgs) ) ! & -! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxh(mgs)))* & -! & Sqrt(axh(mgs)*rhovt(mgs)) ) +! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))* & +! & Sqrt(axx(mgs,lh)*rhovt(mgs)) ) ENDIF ELSE @@ -15061,6 +15478,7 @@ subroutine nssl_2mom_gs & ENDIF end do + hlvent(:) = 0.0 hlventy(:) = 0.0 @@ -15096,16 +15514,16 @@ subroutine nssl_2mom_gs & del = tmp - dgam*i g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxhl(mgs) + tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl) i = Int(dgami*(tmp)) del = tmp - dgam*i y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions - hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxhl(mgs)))*Sqrt(axhl(mgs)*rhovt(mgs)) + hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))*Sqrt(axx(mgs,lhl)*rhovt(mgs)) hlvent(mgs) = 0.78*x + y*hlventy(mgs) ! & -! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxhl(mgs)))* & -! & Sqrt(axhl(mgs)*rhovt(mgs))) +! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))* & +! & Sqrt(axx(mgs,lhl)*rhovt(mgs))) ! : Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp ENDIF @@ -15168,6 +15586,7 @@ subroutine nssl_2mom_gs & qhfzhlg(:) = 0.0 qhlfzhllg(:) = 0.0 vhfzh(:) = 0.0 + vffzf(:) = 0.0 vhlfzhl(:) = 0.0 qsfzs(:) = 0.0 zsmlr(:) = 0.0 @@ -15192,6 +15611,7 @@ subroutine nssl_2mom_gs & ! qhlsave(:) = 0.0 chlmlrr(:) = 0.0 + if ( .not. mixedphase ) then !{ do mgs = 1,ngscnt ! @@ -15203,6 +15623,7 @@ subroutine nssl_2mom_gs & & (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & ! /rhosm & & , 0.0 ) ENDIF + ! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs), ! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv) @@ -15225,8 +15646,9 @@ subroutine nssl_2mom_gs & & , 0.0 ) ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results - write(0,*) 'ibinhmlr = 1 not available for 2-moment' - STOP + errmsg = 'ibinhmlr = 1 not available for 2-moment' + errflg = 1 + RETURN ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN @@ -15349,7 +15771,7 @@ subroutine nssl_2mom_gs & ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lh,1) ) x = gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp - y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxh(mgs), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh), ratio)/g1palp hwvent1 = 0.78*x + y*hwventy(mgs) @@ -15430,7 +15852,7 @@ subroutine nssl_2mom_gs & ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lhl,1) ) x = gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp - y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxhl(mgs), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl), ratio)/g1palp hwvent1 = 0.78*x + y*hlventy(mgs) @@ -15780,9 +16202,9 @@ subroutine nssl_2mom_gs & qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) - qhdpv(mgs) = Max(qhdsv(mgs), 0.0) + qhlsbv(mgs) = 0.0 qhldpv(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN @@ -15936,6 +16358,7 @@ subroutine nssl_2mom_gs & & + qhacr(mgs) & & + qhacw(mgs) ! + qhldry(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & @@ -15965,6 +16388,7 @@ subroutine nssl_2mom_gs & qhwet(mgs) = max( 0.0, qhwet(mgs)) ! ENDIF + qhlwet(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN qhlwet(mgs) = & @@ -16003,7 +16427,6 @@ subroutine nssl_2mom_gs & wetsfchl(:) = .false. wetgrowthhl(:) = .false. - do mgs = 1,ngscnt ! ! @@ -16042,7 +16465,6 @@ subroutine nssl_2mom_gs & qsshr(mgs) = -qsdry(mgs) qhshr(mgs) = -qhdry(mgs) qhlshr(mgs) = -qhldry(mgs) - ELSE ! new and correct qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) @@ -16061,7 +16483,6 @@ subroutine nssl_2mom_gs & wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) ! ENDIF - if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) @@ -16072,9 +16493,6 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) - ! why is there a number loss for graupel for shedding? NEED TO CHECK THIS - ! chshr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) - ! IF ( temg(mgs) < tfr ) chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding @@ -16084,23 +16502,6 @@ subroutine nssl_2mom_gs & ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain - IF ( .false. ) THEN - IF ( temg(mgs) < tfr ) THEN - chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding - ELSE - IF(imltshddmr > 0) THEN - ! DTD: If Dmg < sheddiam, then assume complete melting into - ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop - tmp = -Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain - tmp2 = -rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter - chshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) - chshrr(mgs) = -Max(tmp,Min(tmp2,chshrr(mgs))) - ELSE - chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to maximum size allowed for rain or 4.5mm diameter, whichever is smaller -! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain - ENDIF - ENDIF - ENDIF chlshr(mgs) = 0.0 @@ -16117,27 +16518,8 @@ subroutine nssl_2mom_gs & ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain - - IF ( .false. ) THEN - IF ( temg(mgs) < tfr ) THEN - chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding -! chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vr1mm) ) ! maximum of 1mm drops from shedding - ELSE - IF(imltshddmr > 0) THEN - ! DTD: If Dmg < sheddiam, then assume complete melting into - ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop - tmp = -Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain - tmp2 = -rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter - chlshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lhl,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(sheddiam0-sheddiam) - chlshrr(mgs) = -Max(tmp,Min(tmp2,chlshrr(mgs))) - ELSE - chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to 4.5mm diameter or maximum size allowed for rain, whichever is smaller -! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain - ENDIF - ENDIF - ENDIF - ENDIF ! ( lhl > 1 ) + end do end if @@ -16304,7 +16686,6 @@ subroutine nssl_2mom_gs & ! qhlwet(mgs) = 0.0 end if - end do ! ! Ice -> graupel conversion @@ -16391,7 +16772,7 @@ subroutine nssl_2mom_gs & chcnhl(:) = 0.0 vhcnhl(:) = 0.0 zhcnhl(:) = 0.0 - + IF ( lhl .gt. 1 ) THEN @@ -16483,70 +16864,6 @@ subroutine nssl_2mom_gs & ELSEIF ( ihlcnh == 3 ) THEN !{ - IF ( wtest .and. & - ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN - ! convert number, mass, and reflectivity for d > dw - IF ( ipconc == 5 ) THEN - dg0(mgs) = Min( dg0(mgs), hldia1 ) - !dg0(mgs) = hldia1 - ENDIF - - ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) - - - ! mass - tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) - IF ( ipconc == 5 ) THEN - ! tmp2 = Min( 0.25, tmp2 ) - ENDIF - qxd1 = qx(mgs,lh)*(tmp2) - qhlcnh(mgs) = dtpinv*qxd1 - - - - IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN - - ! number - tmp = gaminterp(ratio,alpha(mgs,lh),1,1) - IF ( ipconc == 5 ) THEN - ! tmp = Min( 0.2, tmp ) - ENDIF - cxd1 = cx(mgs,lh)*( tmp) - chlcnh(mgs) = dtpinv*cxd1 - chlcnhhl(mgs) = chlcnh(mgs) - - IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN - dh0 = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs) - IF ( dh0 < xmas(mgs,lhl) ) THEN - ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average - dh0 = (( qxd1*dh0**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average - chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 ) - ELSE -! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size - ENDIF - ENDIF - - - - ELSE - qhlcnh(mgs) = 0.0 - ENDIF - -! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN -! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! ENDIF - -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 -! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 -! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 -! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 - - vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) - vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) - - ENDIF ENDIF !} @@ -16554,47 +16871,6 @@ subroutine nssl_2mom_gs & ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion -! -! Staka and Mansell (2005) type conversion -- assuming alphah = 0 for now! -! -! hldia1 is set in micro_module and namelist - IF ( .true. ) THEN - - ! convert number, mass, and reflectivity for d > hldia1, - ! regardless of wet growth status, but as long as riming > 0 - DO mgs = 1,ngscnt - IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN - ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) - - ! number - tmp = gaminterp(ratio,alpha(mgs,lh),1,1) - cxd1 = cx(mgs,lh)*( tmp) - chlcnh(mgs) = dtpinv*cxd1 - chlcnhhl(mgs) = chlcnh(mgs) - - ! mass - tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) - qxd1 = qx(mgs,lh)*(tmp2) - qhlcnh(mgs) = dtpinv*qxd1 - -! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN -! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! ENDIF - -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 -! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 -! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 -! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 - - vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) - vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) - - ENDIF - - ENDDO - ELSEIF ( ihlcnh == 0 ) THEN do mgs = 1,ngscnt @@ -16619,7 +16895,7 @@ subroutine nssl_2mom_gs & end if end do - ENDIF ! true +! ENDIF ! true ENDIF ! ihlcnh options @@ -16637,9 +16913,10 @@ subroutine nssl_2mom_gs & ENDIF - ENDIF ! lhl > 1 + + ! ! Ziegler snow conversion to graupel @@ -16886,7 +17163,6 @@ subroutine nssl_2mom_gs & chcev(:) = 0.0 qhlcev(:) = 0.0 chlcev(:) = 0.0 - IF ( lhwlg > 1 ) THEN qhcevlg(:) = 0.0 chcevlg(:) = 0.0 @@ -16910,7 +17186,6 @@ subroutine nssl_2mom_gs & qhmul1(:) = 0.0 qhlmul1(:) = 0.0 qsmul1(:) = 0.0 - do mgs = 1,ngscnt ltest = qx(mgs,lh) .gt. qxmin(lh) @@ -17077,7 +17352,6 @@ subroutine nssl_2mom_gs & ! qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) - IF ( lhl .gt. 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN tmp = fimt1(mgs)*(fimta(mgs) + & @@ -17304,11 +17578,13 @@ subroutine nssl_2mom_gs & ! rimc2 = 0.44 ! ! -! zero som arrays +! zero some arrays ! ! do mgs = 1,ngscnt qrshr(mgs) = 0.0 + qwshw(mgs) = 0.0 + cwshw(mgs) = 0.0 qsshrp(mgs) = 0.0 qhshrp(mgs) = 0.0 end do @@ -17320,6 +17596,8 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) + + IF ( ipconc .ge. 3 ) THEN ! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) ) ENDIF @@ -17431,7 +17709,7 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 2 ) THEN do mgs = 1,ngscnt - pccwi(mgs) = (0.0) ! + (1-il5(mgs))*(-cirmlw(mgs)) + pccwi(mgs) = (0.0) - cwshw(mgs) ! + (1-il5(mgs))*(-cirmlw(mgs)) IF ( warmonly < 0.5 ) THEN pccwd(mgs) = & @@ -17560,6 +17838,8 @@ subroutine nssl_2mom_gs & & +crcev(mgs) & & - cracr(mgs) ! > -il5(mgs)*ciracr(mgs) + + ELSEIF ( warmonly < 0.8 ) THEN pcrwi(mgs) = & & crcnw(mgs) & @@ -17665,7 +17945,7 @@ subroutine nssl_2mom_gs & IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp) - pqswd(mgs) = frac*pqswd(mgs) + pcswd(mgs) = frac*pcswd(mgs) chacs(mgs) = frac*chacs(mgs) chlacs(mgs) = frac*chlacs(mgs) @@ -17698,9 +17978,9 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 5 ) THEN ! do mgs = 1,ngscnt pchwi(mgs) = & - & +(ifrzg*crfrzf(mgs) & - & +il5(mgs)*ifiacrg*(ciacrf(mgs) )) & - & + chcnsh(mgs) + chcnih(mgs) + chcnhl(mgs) + & +(ffrzh*ifrzg*crfrzf(mgs) & + & +il5(mgs)*ffrzh*ifiacrg*(ciacrf(mgs) )) & + & + f2h*chcnsh(mgs) + f2h*chcnih(mgs) + chcnhl(mgs) pchwd(mgs) = & & (1-il5(mgs))*chmlr(mgs) & @@ -17708,7 +17988,11 @@ subroutine nssl_2mom_gs & & + chsbv(mgs) & & - il5(mgs)*chlcnh(mgs) & & - cscnh(mgs) + end do + + + ! ! @@ -17716,7 +18000,7 @@ subroutine nssl_2mom_gs & ! IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN ! do mgs = 1,ngscnt - pchli(mgs) = ((1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*(1.0-ifiacrg)*(ciacrf(mgs) )) & + pchli(mgs) = (ffrzh*(1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*ffrzh*(1.0-ifiacrg)*(ciacrf(mgs) )) & & + chlcnhhl(mgs) *rzxhlh(mgs) pchld(mgs) = & @@ -17739,6 +18023,7 @@ subroutine nssl_2mom_gs & ENDIF ENDIF + end do ENDIF @@ -17834,6 +18119,8 @@ subroutine nssl_2mom_gs & pqlwlghld(:) = 0.0 pqlwhli(:) = 0.0 pqlwhld(:) = 0.0 + + ! ! Vapor ! @@ -17890,7 +18177,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt - pqcwi(mgs) = (0.0) + qwcnr(mgs) + pqcwi(mgs) = (0.0) + qwcnr(mgs) - qwshw(mgs) IF ( warmonly < 0.5 ) THEN pqcwd(mgs) = & @@ -18016,9 +18303,11 @@ subroutine nssl_2mom_gs & & -qhmlr(mgs) & !null at this point when wet snow/graupel included & -qsmlr(mgs) - qhlmlr(mgs) & & -qimlr(mgs)) & - & -qsshr(mgs) & !null at this point when wet snow/graupel included - & -qhshr(mgs) & !null at this point when wet snow/graupel included - & -qhlshr(mgs) +! & -qsshr(mgs) & !null at this point when wet snow/graupel included +! & -qhshr(mgs) & !null at this point when wet snow/graupel included +! & -qhlshr(mgs) & + & - qrshr(mgs) + pqrwd(mgs) = & & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & @@ -18027,10 +18316,10 @@ subroutine nssl_2mom_gs & pqrwi(mgs) = & & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & & +(1-il5(mgs))*( & - & -qhmlr(mgs) & !null at this point when wet snow/graupel included - & -qhshr(mgs) & !null at this point when wet snow/graupel included & -qhlmlr(mgs) & !null at this point when wet snow/graupel included - & -qhlshr(mgs) ) !null at this point when wet snow/graupel included + & -qhmlr(mgs) ) & !null at this point when wet snow/graupel included + & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) !null at this point when wet snow/graupel included pqrwd(mgs) = & & il5(mgs)*(-qrfrz(mgs)) & & - qhacr(mgs) & @@ -18179,13 +18468,13 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt pqhwi(mgs) = & - & +il5(mgs)*(ifrzg*qrfrzf(mgs) + (1-il3(mgs))*(ifiacrg)*(qiacrf(mgs)+qracif(mgs))) & - & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & + & +il5(mgs)*(ffrzh*ifrzg*qrfrzf(mgs) + (1-il3(mgs))*ffrzh*ifiacrg*(qiacrf(mgs)+qracif(mgs))) & + & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & ! only used for ipconc < 3 & +il5(mgs)*(qhdpv(mgs)) & & +Max(0.0, qhcev(mgs)) & & +qhacr(mgs)+qhacw(mgs) & & +qhacs(mgs)+qhaci(mgs) & - & + qhcns(mgs) + qhcni(mgs) + qhcnhl(mgs) + & + f2h*qhcns(mgs) + f2h*qhcni(mgs) + qhcnhl(mgs) pqhwd(mgs) = & & qhshr(mgs) & !null at this point when wet graupel included & +(1-il5(mgs))*qhmlr(mgs) & !null at this point when wet graupel included @@ -18193,10 +18482,12 @@ subroutine nssl_2mom_gs & & + qhsbv(mgs) & & + Min(0.0, qhcev(mgs)) & & -qhmul1(mgs) - qhlcnh(mgs) - qscnh(mgs) & - & - qsplinter(mgs) - qsplinter2(mgs) + & - ffrzh*(qsplinter(mgs) + qsplinter2(mgs)) ! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + end do + ! ! Hail ! @@ -18302,7 +18593,7 @@ subroutine nssl_2mom_gs & vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation ! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) ! vhlsoak(:) = 0.0 - + ENDIF ! mixedphase @@ -18351,16 +18642,16 @@ subroutine nssl_2mom_gs & ! : + il5(mgs)*qrfrzf(mgs)/rhofrz ) pvhwi(mgs) = rho0(mgs)*( & - & +il5(mgs)*( ifiacrg*qracif(mgs))/rhofrz & + & +il5(mgs)*( ifiacrg*ffrzh*qracif(mgs))/rhofrz & !erm > + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)? & & + ( il5(mgs)*qhdpv(mgs)/qhdpvdn & & + (qhacs(mgs) + qhaci(mgs))/qhacidn ) ) & & + rho0(mgs)*Max(0.0, qhcev(mgs))/1000. & ! only used in mixed phase: evaporation/condensation of liquid water coating ! > + qhacs(mgs) + qhaci(mgs) )/xdn0(ls) ) & - & + vhcns(mgs) & + & + f2h*vhcns(mgs) & & + vhacr(mgs) + vhacw(mgs) + vhfzh(mgs) & ! qhacw(mgs)/rimdn(mgs,lh) ! > + vhfrh(mgs) & - & + vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs)) + & + f2h*vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs))*ffrzh ! > +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh) ! pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh) @@ -18445,13 +18736,13 @@ subroutine nssl_2mom_gs & DO mgs = 1,ngscnt pvhli(mgs) = rho0(mgs)*( & - & + ( il5(mgs)*(((1.0-ifiacrg)*qracif(mgs))/rhofrz + qhldpv(mgs) ) & + & + ( il5(mgs)*(((1.0-ifiacrg)*ffrzh*qracif(mgs))/rhofrz + qhldpv(mgs) ) & ! & + Max(0.0, qhlcev(mgs)) & ! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) ) & ! xdn0(ls) ) & ! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose & + qhlacs(mgs) + qhlaci(mgs) )/500. ) & ! changed to 500 instead of min graupel density to keep hail density from dropping too much & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & - & + vhlcnhl(mgs) + ((1.0-ifiacrg)*viacrf(mgs) + (1.0-ifrzg)*vrfrzf(mgs)) & + & + vhlcnhl(mgs) + ((1.0-ifiacrg)*ffrzh*viacrf(mgs) + (1.0-ifrzg)*ffrzh*vrfrzf(mgs)) & & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl) pvhld(mgs) = rho0(mgs)*( & @@ -18482,6 +18773,7 @@ subroutine nssl_2mom_gs & & + pqhwi(mgs) + pqhwd(mgs) & & + pqhli(mgs) + pqhld(mgs) ! + ENDDO @@ -18587,6 +18879,7 @@ subroutine nssl_2mom_gs & write(iunit,*) cwacii(mgs),cwfrzc(mgs),cwctfzc(mgs) write(iunit,*) cicichr(mgs) write(iunit,*) chmul1(mgs) + write(iunit,*) cfmul1(mgs) write(iunit,*) chlmul1(mgs) write(iunit,*) csmul(mgs) ! @@ -18923,6 +19216,8 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 ) THEN cx(mgs,lhl) = cx(mgs,lhl) + & & dtp*(pchli(mgs)+pchld(mgs)) + + ENDIF @@ -18931,7 +19226,7 @@ subroutine nssl_2mom_gs & end if - IF ( wrfchem_flag > 0 ) THEN + IF ( has_wetscav ) THEN DO mgs = 1,ngscnt evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + & @@ -19426,6 +19721,104 @@ subroutine nssl_2mom_gs & ! ! Load the save arrays ! + IF ( numproc > 1 ) THEN + DO mgs = 1,ngscnt + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + IF ( ipconc > 2 ) THEN + thproc(kzbeg-1+kgs(mgs),1) = thproc(kzbeg-1+kgs(mgs),1) + crfrzf(mgs)*dtp*dv + ELSE + thproc(kzbeg-1+kgs(mgs),1) = thproc(kzbeg-1+kgs(mgs),1) + qrfrzf(mgs)*rho0(mgs)*dtp*dv + ENDIF + thproc(kzbeg-1+kgs(mgs),2) = thproc(kzbeg-1+kgs(mgs),2) + il5(mgs)*ciacrf(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),3) = thproc(kzbeg-1+kgs(mgs),3) + chcnsh(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),4) = thproc(kzbeg-1+kgs(mgs),4) + chcnih(mgs)*dtp*dv + IF ( qhacw(mgs)+qhacr(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN + thproc(kzbeg-1+kgs(mgs),5) = thproc(kzbeg-1+kgs(mgs),5) + (qhacw(mgs)+qhacr(mgs)+qhshr(mgs))*rho0(mgs)*dtp*dv + ENDIF + thproc(kzbeg-1+kgs(mgs),6) = thproc(kzbeg-1+kgs(mgs),6) + qracw(mgs)*rho0(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),7) = thproc(kzbeg-1+kgs(mgs),7) + qrcnw(mgs)*rho0(mgs)*dtp*dv + IF ( qhacw(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN + thproc(kzbeg-1+kgs(mgs),8) = thproc(kzbeg-1+kgs(mgs),8) + (vhacw(mgs)+vhacr(mgs)+vhshdr(mgs))*dtp*dv +! thproc(kzbeg-1+kgs(mgs),8) = thproc(kzbeg-1+kgs(mgs),8) + qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh)*dtp*dv + ENDIF + thproc(kzbeg-1+kgs(mgs),9) = thproc(kzbeg-1+kgs(mgs),9) + ptem(mgs)*dtp*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),10) = thproc(kzbeg-1+kgs(mgs),10) + & + & ( chmul1(mgs) + chlmul1(mgs) )*dtp*dv + IF ( lf > 1 ) THEN + ELSE + thproc(kzbeg-1+kgs(mgs),11) = thproc(kzbeg-1+kgs(mgs),11) + & + & ( csplinter(mgs) + csplinter2(mgs) )*dtp*dv + ENDIF + thproc(kzbeg-1+kgs(mgs),12) = thproc(kzbeg-1+kgs(mgs),12) + qrfrzf(mgs)*rho0(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),13) = thproc(kzbeg-1+kgs(mgs),13) + il5(mgs)*qiacrf(mgs)*rho0(mgs)*dtp*dv ! mass of rain freezing by ice crystal capture + thproc(kzbeg-1+kgs(mgs),14) = thproc(kzbeg-1+kgs(mgs),14) + crcnw(mgs)*dtp*dv ! rain drop prod. by autoconv. + thproc(kzbeg-1+kgs(mgs),15) = thproc(kzbeg-1+kgs(mgs),15) + (pcrwi(mgs)-crcnw(mgs))*dtp*dv ! rain drop prod by melting/shedding (i.e., everything but autoconv.) +! thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate + thproc(kzbeg-1+kgs(mgs),19) = thproc(kzbeg-1+kgs(mgs),19) + pmlt(mgs)*rho0(mgs)*dv ! melting rate + thproc(kzbeg-1+kgs(mgs),20) = thproc(kzbeg-1+kgs(mgs),20) + pdep(mgs)*rho0(mgs)*dv ! deposition rate + thproc(kzbeg-1+kgs(mgs),21) = thproc(kzbeg-1+kgs(mgs),21) + (psub(mgs)-pdep(mgs))*rho0(mgs)*dv ! sublimation rate + thproc(kzbeg-1+kgs(mgs),22) = thproc(kzbeg-1+kgs(mgs),22) + (pfrz(mgs)-pmlt(mgs))*rho0(mgs)*dv ! freezing rate + +! thproc(kzbeg-1+kgs(mgs),20) = thproc(kzbeg-1+kgs(mgs),20) + (1./pi0(mgs))*felfcp(mgs)*pvap(mgs)*rho0(mgs)*dv ! deposition rate +! thproc(kzbeg-1+kgs(mgs),21) = thproc(kzbeg-1+kgs(mgs),21) + (1./pi0(mgs))*felscp(mgs)*psub(mgs)*rho0(mgs)*dv ! sublimation rate +! thproc(kzbeg-1+kgs(mgs),22) = thproc(kzbeg-1+kgs(mgs),22) + (1./pi0(mgs))*felfcp(mgs)*pfrz(mgs)*rho0(mgs)*dv ! (pfrz(mgs)-pmlt(mgs))*rho0(mgs)*dv ! freezing rate + + thproc(kzbeg-1+kgs(mgs),23) = thproc(kzbeg-1+kgs(mgs),23) + crfrzs(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),24) = thproc(kzbeg-1+kgs(mgs),24) + il5(mgs)*ciacrs(mgs)*dtp*dv + + thproc(kzbeg-1+kgs(mgs),25) = thproc(kzbeg-1+kgs(mgs),25) + qhmlr(mgs)*rho0(mgs)*dv ! melting rate + thproc(kzbeg-1+kgs(mgs),26) = thproc(kzbeg-1+kgs(mgs),26) + qhlmlr(mgs)*rho0(mgs)*dv ! melting rate + + IF ( qhlacw(mgs)+qhlacr(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN + thproc(kzbeg-1+kgs(mgs),27) = thproc(kzbeg-1+kgs(mgs),27) + (qhlacw(mgs)+qhlacr(mgs)+qhlshr(mgs))*rho0(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),28) = thproc(kzbeg-1+kgs(mgs),28) + (qhlacw(mgs))*rho0(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),29) = thproc(kzbeg-1+kgs(mgs),29) + (qhlacr(mgs))*rho0(mgs)*dtp*dv + ENDIF + + IF ( temg(mgs) < tfr ) THEN + thproc(kzbeg-1+kgs(mgs),30) = thproc(kzbeg-1+kgs(mgs),30) + (qhacw(mgs))*rho0(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),31) = thproc(kzbeg-1+kgs(mgs),31) + (qhacr(mgs))*rho0(mgs)*dtp*dv + ENDIF + + thproc(kzbeg-1+kgs(mgs),32) = thproc(kzbeg-1+kgs(mgs),32) + qhlcnh(mgs)*rho0(mgs)*dtp*dv ! graupel mass conversion to hail + + IF ( ihrn > 0 ) THEN + thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + ciihr(mgs)*dtp*dv ! contact freezing of droplets + ELSE + IF ( qwctfz(mgs)*dtp >= qxmin(li) ) THEN + thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + cwctfz(mgs)*dtp*dv ! contact freezing of droplets + ENDIF + ENDIF + thproc(kzbeg-1+kgs(mgs),34) = thproc(kzbeg-1+kgs(mgs),34) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate + IF ( qiint(mgs)*dtp >= qxmin(li) ) THEN + thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + ciint(mgs)*dtp*dv ! primary ice initiation + ENDIF + IF ( lf > 1 ) THEN + ELSE + thproc(kzbeg-1+kgs(mgs),38) = thproc(kzbeg-1+kgs(mgs),38) + (vhacw(mgs)+vhacr(mgs)+vhshdr(mgs))*dtp*dv + ENDIF + IF ( lhl > 1 ) THEN + thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + chlcnhhl(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),37) = thproc(kzbeg-1+kgs(mgs),37) + (vhlacw(mgs)+vhlacr(mgs)+vhlshdr(mgs))*dtp*dv + ELSE + IF ( lf > 1 ) THEN + ELSE + thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + (pchwi(mgs))*dtp*dv + thproc(kzbeg-1+kgs(mgs),39) = thproc(kzbeg-1+kgs(mgs),39) + (pchwd(mgs))*dtp*dv + thproc(kzbeg-1+kgs(mgs),37) = thproc(kzbeg-1+kgs(mgs),37) + (chmlr(mgs))*dtp*dv + ENDIF + ENDIF +! thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate + + +! ptem(mgs) = & +! & (1./pi0(mgs))* & +! & (felfcp(mgs)*pfrz(mgs) & +! & +felscp(mgs)*psub(mgs) & +! & +felvcp(mgs)*pvap(mgs)) + + ENDDO + ENDIF ! Sample code for using the axtra array to load microphysical rates or quantities for output @@ -19461,6 +19854,10 @@ subroutine nssl_2mom_gs & DO il = lc,lhab IF ( ido(il) .eq. 1 ) THEN + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,1) = an(igs(mgs),jy,kgs(mgs),il) + lfsave(mgs,2) = qx(mgs,il) + ENDIF an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) + & & min( an(igs(mgs),jy,kgs(mgs),il), 0.0 ) qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il) @@ -19541,7 +19938,19 @@ subroutine nssl_2mom_gs & ENDIF ! } DO mgs = 1,ngscnt + + IF ( il == lh ) THEN + IF ( lnhf > 1 ) THEN ! number of graupel from frozen drops + an(igs(mgs),jy,kgs(mgs),lnhf) = Max( chxf(mgs,lh), 0.0) + ENDIF + ENDIF + IF ( il == lhl ) THEN + + IF ( lnhlf > 1 ) THEN ! number of hail from frozen drops +! an(igs(mgs),jy,kgs(mgs),lnhlf) = Min( cx(mgs,lhl), Max( chxf(mgs,lhl), 0.0) ) + an(igs(mgs),jy,kgs(mgs),lnhlf) = Max( chxf(mgs,lhl), 0.0) + ENDIF ENDIF an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) ENDDO diff --git a/physics/mp_nsslg.F90 b/physics/mp_nssl.F90 similarity index 58% rename from physics/mp_nsslg.F90 rename to physics/mp_nssl.F90 index a2dc50cce..84531244e 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nssl.F90 @@ -1,17 +1,17 @@ -!>\file mp_nsslg.F90 +!>\file mp_nssl.F90 !! This file contains NSSL 2-moment MP scheme. -!>\defgroup aansslg NSSL MP Module +!>\defgroup aanssl NSSL MP Module !! This module contains the NSSL microphysics scheme. -module mp_nsslg +module mp_nssl use machine, only : kind_phys, kind_real use module_mp_nssl_2mom, only : nssl_2mom_init, nssl_2mom_driver implicit none - public :: mp_nsslg_init, mp_nsslg_run, mp_nsslg_finalize + public :: mp_nssl_init, mp_nssl_run, mp_nssl_finalize private logical :: is_initialized = .False. @@ -20,90 +20,141 @@ module mp_nsslg contains !> This subroutine is a wrapper around the nssl_2mom_init(). -!! \section arg_table_mp_nsslg_init Argument Table -!! \htmlinclude mp_nsslg_init.html +!! \section arg_table_mp_nssl_init Argument Table +!! \htmlinclude mp_nssl_init.html !! - subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & - mpicomm, mpirank, mpiroot, & - imp_physics, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & - nssl_cccn, nssl_alphah, nssl_alphahl, nssl_hail_on) + subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & + mpicomm, mpirank, mpiroot, & + imp_physics, imp_physics_nssl, & + nssl_cccn, nssl_alphah, nssl_alphahl, & + nssl_ccn_on, nssl_hail_on, nssl_invertccn, first_time_step, & + spechum, qc, qr, qi, qs, qh, qhl, & + cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl, & + csw_phys ) + + use module_mp_nssl_2mom, only: nssl_2mom_init, calcnfromq, na + use physcons, only: con_rd implicit none - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg integer, intent(in) :: ncol integer, intent(in) :: nlev + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + integer, intent(in) :: threads + logical, intent(in) :: restart integer, intent(in) :: mpicomm integer, intent(in) :: mpirank integer, intent(in) :: mpiroot - integer, intent(in) :: threads integer, intent(in) :: imp_physics - integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn + integer, intent(in) :: imp_physics_nssl real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl - logical, intent(in) :: nssl_hail_on + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + logical, intent(in) :: first_time_step + + ! Hydrometeors + real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) + 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) :: qhl(:,:) ! (1:ncol,1:nlev) ! hail + real(kind_phys), intent(inout) :: cccn(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccna(:,:) ! (1:ncol,1:nlev) ! currently not used + 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) :: chl(:,:) ! (1:ncol,1:nlev) ! hail number + real(kind_phys), intent(inout) :: vh(1:ncol,1:nlev) ! graupel volume + real(kind_phys), intent(inout) :: vhl(:,:) ! (1:ncol,1:nlev) ! hail volume + + real(kind_phys), intent(inout) :: csw_phys(1:ncol,1:nlev) + + ! State variables and timestep information + real(kind_phys), intent(inout) :: tgrs(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prsl(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prslk(1:ncol,1:nlev) + ! Air density + real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 + ! Hydrometeors +! real(kind_phys) :: qv_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) +! real(kind_phys) :: qc_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) +! real(kind_phys) :: qr_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) +! real(kind_phys) :: qi_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) +! real(kind_phys) :: qs_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) +! real(kind_phys) :: qh_mp(1:ncol,1:nlev) !< kg kg-1 (graupel dry mixing ratio) + real(kind_phys) :: qhl_mp(1:ncol,1:nlev) !< kg kg-1 (hail dry mixing ratio) +! real(kind_phys) :: nc_mp(1:ncol,1:nlev) !< droplet num. conc. +! real(kind_phys) :: nr_mp(1:ncol,1:nlev) !< rain num. conc. +! real(kind_phys) :: ni_mp(1:ncol,1:nlev) !< ice crystal num. conc. +! real(kind_phys) :: ns_mp(1:ncol,1:nlev) !< snow num. conc. +! real(kind_phys) :: nh_mp(1:ncol,1:nlev) !< graupel num. conc. +! real(kind_phys) :: nhl_mp(1:ncol,1:nlev) !< hail num. conc. + real(kind_phys) :: vh_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + real(kind_phys) :: cccn_mp(1:ncol,1:nlev) + real(kind_phys) :: cccna_mp(1:ncol,1:nlev) + ! create temporaries for hail in case it does not exist + real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) + real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + + real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array ! Local variables: dimensions used in nssl_init - integer :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte + integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k real :: nssl_params(20) integer :: ihailv - + ! Initialize the CCPP error handling variables errflg = 0 errmsg = '' +! write(0,*) 'nssl_init: nlev,ncol,rank = ',nlev,ncol,mpirank - if (is_initialized) return + if (is_initialized .and. .not. first_time_step ) return + IF ( .not. is_initialized ) THEN ! only do this on first call if (mpirank==mpiroot) then write(0,*) ' ----------------------------------------------------------------------------------------------------------------' - write(0,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development, use at your own risk --- WARNING ---' + write(0,*) ' --- CCPP NSSL MP scheme init ---' +! write(0,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development --- WARNING ---' write(0,*) ' ----------------------------------------------------------------------------------------------------------------' write(6,*) ' ----------------------------------------------------------------------------------------------------------------' - write(6,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development, use at your own risk --- WARNING ---' +! write(6,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development --- WARNING ---' + write(6,*) ' --- CCPP NSSL MP scheme init ---' write(6,*) ' ----------------------------------------------------------------------------------------------------------------' end if -! IF ( kind_phys /= kind_real ) THEN -! errflg = 1 -! write(errmsg,'(a)') 'NSSL MP does not yet work for double precision. Compile for single precision' -! return -! ENDIF +! update this when ccn_flag is active? + if ( imp_physics /= imp_physics_nssl ) then + write(errmsg,'(*(a))') "Logic error: namelist choice of microphysics is different from NSSL" + errflg = 1 + return + end if ! Set internal dimensions - ids = 1 ims = 1 - its = 1 - ide = ncol ime = ncol - ite = ncol - jds = 1 + nx = ncol jms = 1 - jts = 1 - jde = 1 jme = 1 - jte = 1 - kds = 1 kms = 1 - kts = 1 - kde = nlev kme = nlev - kte = nlev + nz = nlev nssl_params(:) = 0.0 nssl_params(1) = nssl_cccn nssl_params(2) = nssl_alphah nssl_params(3) = nssl_alphahl - nssl_params(4) = 4.e5 ! nssl_cnoh - nssl_params(5) = 4.e4 ! nssl_cnohl - nssl_params(6) = 4.e5 ! nssl_cnor - nssl_params(7) = 4.e6 ! nssl_cnos + nssl_params(4) = 4.e5 ! nssl_cnoh -- not used for 2-moment + nssl_params(5) = 4.e4 ! nssl_cnohl-- not used for 2-moment + nssl_params(6) = 4.e5 ! nssl_cnor-- not used for 2-moment + nssl_params(7) = 4.e6 ! nssl_cnos-- not used for 2-moment nssl_params(8) = 500. ! nssl_rho_qh nssl_params(9) = 800. ! nssl_rho_qhl nssl_params(10) = 100. ! nssl_rho_qs @@ -112,9 +163,9 @@ subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off nssl_qccn = nssl_cccn/1.225 - if (mpirank==mpiroot) then - write(*,*) 'nssl_init: nssl_qccn = ',nssl_qccn - endif + ! if (mpirank==mpiroot) then + ! write(*,*) 'nssl_init: nssl_qccn = ',nssl_qccn + ! endif IF ( nssl_hail_on ) THEN ihailv = 1 @@ -122,64 +173,159 @@ subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & ihailv = -1 ENDIF - IF ( imp_physics == imp_physics_nssl2m ) THEN + IF ( imp_physics == imp_physics_nssl ) THEN ! ( .not. nssl_ccn_flag ) ! write(0,*) 'call nssl_2mom_init' - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & + ihvol=ihailv,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) ! write(0,*) 'done nssl_2mom_init' - ELSEIF ( imp_physics == imp_physics_nssl2mccn ) THEN -! write(0,*) 'call nssl_2mom_init ccn' - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) -! write(0,*) 'done nssl_2mom_init ccn' - ELSE +! ELSE ! write(0,*) 'call nssl_2mom_init ccn: imp_physics, imp_physics_nssl2mccn = ',imp_physics, imp_physics_nssl2mccn - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) +! CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) ! write(0,*) 'done nssl_2mom_init ccn' ENDIF is_initialized = .true. + + ENDIF ! .not. is_initialized + +! IF ( is_initialized .and. ((.not. first_time_step) .or. restart ) ) THEN +! return +! ENDIF + + ! Following code only runs on first time step -- hopefully for all slabs + + !> - Density of air in kg m-3 + rho = prsl/(con_rd*tgrs) + + allocate( an(nx,1,nz,na) ) + an(:,:,:,:) = 0.0 + +! spechum, qc, qr, qi, qs, qh, qhl, & +! cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl ) + + ! use local arrays for variables that might not exist + ! implied loops + IF ( nssl_hail_on ) THEN + qhl_mp = qhl + vhl_mp = vhl + chl_mp = chl + ELSE + qhl_mp = 0 + vhl_mp = 0 + chl_mp = 0 + ENDIF + IF ( nssl_ccn_on ) THEN + cccn_mp = nssl_qccn ! cccn + cccna_mp = 0 + ELSE + cccn_mp = nssl_qccn + cccna_mp = 0 + ENDIF +! qr_mp = qr +! qs_mp = qs +! write(0,*) 'mp_nssl_init1: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh),maxval(rho) +! write(0,*) 'mp_nssl_init: call calcnfromq',restart,is_initialized,first_time_step + call calcnfromq(nx=nx,ny=1,nz=nz,an=an,na=na,nor=0,norz=0,dn=rho, & + & qcw=qc,qci=qi,qsw=qs,qrw=qr,qhw=qh,qhl=qhl_mp, & + & ccw=ccw,cci=cci,csw=csw,crw=crw,chw=chw,chl=chl_mp, & + & cccn=cccn_mp,cccna=cccna_mp, vhw=vh,vhl=vhl_mp ) + +! qr = qr_mp +! qs = qs_mp + + ! write(0,*) 'mp_nssl_init2: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh),maxval(rho) + ! write(0,*) 'mp_nssl_init2: ni,ns,nh maxval: ',maxval(cci),maxval(csw),maxval(chw) +! DO k = 1,nz +! DO i = 1,nx +! IF ( qi(i,k) > 1.e-4 ) write(6,*) 'qi,ni = ',qi(i,k),cci(i,k) +! IF ( qs(i,k) > 1.e-3 ) write(6,*) 'qs,ns = ',qs(i,k),csw(i,k) +! IF ( qh(i,k) > 1.e-3 ) write(6,*) 'qh,nh = ',qh(i,k),chw(i,k) +! ENDDO +! ENDDO + + IF ( nssl_hail_on ) THEN + qhl = qhl_mp + vhl = vhl_mp + chl = chl_mp + ENDIF + IF ( nssl_ccn_on ) THEN + IF ( nssl_invertccn ) THEN + !cccn = cccna_mp + DO k = 1,nlev + DO i = 1,ncol + cccn(i,k) = nssl_qccn - cccn_mp(i,k) + ENDDO + ENDDO + ELSE + cccn = cccn_mp + ENDIF + ENDIF + csw_phys = csw + +! qs = 0 +! qi = 0 +! qr = 0 + +! call calc_eff_radius & +! & (nx=im,ny=1,nz=lm,na=1,jyslab=1 & +! & ,nor=0,norz=0 & +! & ,t1=re_cloud,t2=re_ice,t3=re_snow,t4=re_rain & +! & ,qcw=qc_mp,qci=qi_mp,qsw=qs_mp,qrw=qr_mp & +! & ,ccw=nc_mp,cci=ni_mp,csw=ns_mp,crw=nr_mp & +! & ,dn=rho ) + + + + deallocate( an ) + + return - end subroutine mp_nsslg_init + end subroutine mp_nssl_init -!>\ingroup aansslg -!>\section gen_nsslg NSSL MP General Algorithm +!>\ingroup aanssl +!>\section gen_nssl NSSL MP General Algorithm !>@{ -!> \section arg_table_mp_nsslg_run Argument Table -!! \htmlinclude mp_nsslg_run.html +!> \section arg_table_mp_nssl_run Argument Table +!! \htmlinclude mp_nssl_run.html !! - subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & + subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ! spechum, cccn, qc, qr, qi, qs, qh, qhl, & spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & ccw, crw, cci, csw, chw, chl, vh, vhl, & tgrs, prslk, prsl, phii, omega, dtp, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, & - re_cloud, re_ice, re_snow, & + re_cloud, re_ice, re_snow, re_rain, & imp_physics, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & + imp_physics_nssl, nssl_ccn_on, & nssl_hail_on, nssl_invertccn, ntccn, ntccna, & errflg, errmsg) + + use module_mp_nssl_2mom, only: calcnfromq, na + implicit none integer, intent(in) :: ncol, nlev real(kind_phys), intent(in ) :: con_g real(kind_phys), intent(in ) :: con_rd + integer, intent(in) :: mpirank ! Hydrometeors real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) - real(kind_phys), intent(inout) :: cccn(1:ncol,1:nlev) - real(kind_phys), intent(inout) :: cccna(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccn(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccna(:,:) ! (1:ncol,1:nlev) 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) :: qhl(1:ncol,1:nlev) ! hail + real(kind_phys), intent(inout) :: qhl(:,:) ! (1:ncol,1:nlev) ! hail 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) :: chl(1:ncol,1:nlev) ! hail number + real(kind_phys), intent(inout) :: chl(:,:) ! (1:ncol,1:nlev) ! hail number real(kind_phys), intent(inout) :: vh(1:ncol,1:nlev) ! graupel volume - real(kind_phys), intent(inout) :: vhl(1:ncol,1:nlev) ! hail volume + real(kind_phys), intent(inout) :: vhl(:,:) ! (1:ncol,1:nlev) ! hail volume ! State variables and timestep information real(kind_phys), intent(inout) :: tgrs(1:ncol,1:nlev) real(kind_phys), intent(in ) :: prsl(1:ncol,1:nlev) @@ -198,13 +344,13 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & real(kind_phys), intent(inout) :: refl_10cm(1:ncol,1:nlev) logical, intent(in ) :: do_radar_ref, first_time_step ! Cloud effective radii - real(kind_phys), optional, intent(inout) :: re_cloud(1:ncol,1:nlev) - real(kind_phys), optional, intent(inout) :: re_ice(1:ncol,1:nlev) - real(kind_phys), optional, intent(inout) :: re_snow(1:ncol,1:nlev) -! real(kind_phys), optional, intent( out) :: re_rain(1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_cloud(:,:) ! (1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_ice(:,:) ! (1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_snow(:,:) ! (1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_rain(:,:) ! (1:ncol,1:nlev) integer, intent(in) :: imp_physics - integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn - logical, intent(in) :: nssl_hail_on, nssl_invertccn + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn integer, intent(in) :: ntccn, ntccna integer, intent(out) :: errflg @@ -223,10 +369,19 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & real(kind_phys) :: qs_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) real(kind_phys) :: qh_mp(1:ncol,1:nlev) !< kg kg-1 (graupel dry mixing ratio) real(kind_phys) :: qhl_mp(1:ncol,1:nlev) !< kg kg-1 (hail dry mixing ratio) + real(kind_phys) :: nc_mp(1:ncol,1:nlev) !< droplet num. conc. + real(kind_phys) :: nr_mp(1:ncol,1:nlev) !< rain num. conc. + real(kind_phys) :: ni_mp(1:ncol,1:nlev) !< ice crystal num. conc. + real(kind_phys) :: ns_mp(1:ncol,1:nlev) !< snow num. conc. + real(kind_phys) :: nh_mp(1:ncol,1:nlev) !< graupel num. conc. + real(kind_phys) :: nhl_mp(1:ncol,1:nlev) !< hail num. conc. real(kind_phys) :: cn_mp(1:ncol,1:nlev) real(kind_phys) :: cna_mp(1:ncol,1:nlev) + real(kind_phys) :: cccn_mp(1:ncol,1:nlev) + real(kind_phys) :: cccna_mp(1:ncol,1:nlev) + real(kind_phys) :: vh_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) ! create temporaries for hail in case it does not exist - real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) + !real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) ! Vertical velocity and level width real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1 @@ -259,9 +414,11 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & real(kind_phys) :: re_cloud_mp(1:ncol,1:nlev) ! m real(kind_phys) :: re_ice_mp(1:ncol,1:nlev) ! m real(kind_phys) :: re_snow_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_rain_mp(1:ncol,1:nlev) ! m integer :: has_reqc integer :: has_reqi integer :: has_reqs + integer :: has_reqr ! Dimensions used in driver integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -273,13 +430,17 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & integer, parameter :: ndebug = 0 logical, parameter :: convertdry = .true. logical :: invertccn + real :: cwmas + real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array errflg = 0 errmsg = '' - IF ( ndebug > 1 ) write(0,*) 'In physics nsslg_run' +! write(0,*) 'nssl_run: nlev,ncol,rank = ',nlev,ncol,mpirank + + IF ( ndebug > 1 ) write(0,*) 'In physics nssl_run' ! Check initialization state @@ -292,6 +453,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & invertccn = nssl_invertccn !> - Convert specific humidity/moist mixing ratios to dry mixing ratios + ! NOTE: Implied loops! qv_mp = spechum/(1.0_kind_phys-spechum) IF ( convertdry ) THEN qc_mp = qc/(1.0_kind_phys-spechum) @@ -299,8 +461,19 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & qi_mp = qi/(1.0_kind_phys-spechum) qs_mp = qs/(1.0_kind_phys-spechum) qh_mp = qh/(1.0_kind_phys-spechum) + + IF ( nssl_ccn_on ) cccn_mp = cccn/(1.0_kind_phys-spechum) +! cccna_mp = cccna/(1.0_kind_phys-spechum) + nc_mp = ccw/(1.0_kind_phys-spechum) + nr_mp = crw/(1.0_kind_phys-spechum) + ni_mp = cci/(1.0_kind_phys-spechum) + ns_mp = csw/(1.0_kind_phys-spechum) + nh_mp = chw/(1.0_kind_phys-spechum) + vh_mp = vh/(1.0_kind_phys-spechum) IF ( nssl_hail_on ) THEN qhl_mp = qhl/(1.0_kind_phys-spechum) + nhl_mp = chl/(1.0_kind_phys-spechum) + vhl_mp = vhl/(1.0_kind_phys-spechum) ENDIF ELSE ! qv_mp = spechum ! /(1.0_kind_phys-spechum) @@ -309,21 +482,48 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & qi_mp = qi ! /(1.0_kind_phys-spechum) qs_mp = qs ! /(1.0_kind_phys-spechum) qh_mp = qh ! /(1.0_kind_phys-spechum) + IF ( nssl_ccn_on ) cccn_mp = cccn +! cccna_mp = cccna + nc_mp = ccw + nr_mp = crw + ni_mp = cci + ns_mp = csw + nh_mp = chw IF ( nssl_hail_on ) THEN qhl_mp = qhl ! /(1.0_kind_phys-spechum) + nhl_mp = chl + vhl_mp = vhl ENDIF ENDIF IF ( nssl_hail_on ) THEN - chl_mp = chl - vhl_mp = vhl +! nhl_mp = chl +! vhl_mp = vhl ELSE qhl_mp = 0 - chl_mp = 0 + nhl_mp = 0 vhl_mp = 0 ENDIF + IF ( .false. ) THEN + write(6,*) 'nsslrun: qc,max ccw = ',mpirank,maxval(qc_mp),maxval(nc_mp),sum(nc_mp) + IF ( mpirank == 1 ) THEN + DO k=1,nlev + DO i=1,ncol + IF ( qc_mp(i,k) > 1.e-6 .and. nc_mp(i,k) <= 1.e-9 ) THEN + write(6,*) 'i,k,qc,nc,ccn = ',i,k,qc_mp(i,k),nc_mp(i,k),cccn_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + ! IF ( first_time_step ) THEN + ! write(0,*) 'mp_nssl_run: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh) + ! write(0,*) 'mp_nssl_run: ni,ns,nh maxval: ',maxval(ni_mp),maxval(ns_mp),maxval(nh_mp) + ! ENDIF + !> - Density of air in kg m-3 rho = prsl/(con_rd*tgrs) @@ -378,11 +578,13 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & has_reqc = 1 has_reqi = 1 has_reqs = 1 + IF ( present( re_rain ) ) has_reqr = 1 else if (.not.present(re_cloud) .and. .not.present(re_ice) .and. .not.present(re_snow)) then do_effective_radii = .false. has_reqc = 0 has_reqi = 0 has_reqs = 0 + has_reqr = 0 else write(errmsg,fmt='(*(a))') 'Logic error in mp_nssl_run:', & ' all or none of the following optional', & @@ -394,6 +596,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & re_cloud_mp = 0 re_ice_mp = 0 re_snow_mp = 0 + re_rain_mp = 0 ! Set internal dimensions ids = 1 @@ -427,26 +630,53 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ENDIF IF ( first_time_step ) THEN - itimestep = 0 - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + itimestep = 0 ! gets incremented to 1 in call loop + IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN - cccn = 0 + cccn_mp = 0 !cccn = nssl_qccn ELSE - cccn = nssl_qccn + cccn_mp = nssl_qccn ENDIF ENDIF ELSE itimestep = 2 ENDIF - - - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + + ! incoming droplet field may have some inconsistent number concentrations (e.g., from PBL) + ! so check for that, otherwise mass may be zapped into vapor + allocate( an(ncol,1,nlev,na) ) + an(:,:,:,:) = 0.0 ! needed for workspace in routine + + cwmas = 1000.*0.523599*(2.*9.e-6)**3 + + call calcnfromq(nx=ncol,ny=1,nz=nlev,an=an,na=na,nor=0,norz=0,dn=rho, & + & qcw=qc_mp,qci=qi_mp, & + & ccw=nc_mp,cci=ni_mp, & + & cccn=cccn_mp,qv=qv_mp, invertccn_flag=nssl_invertccn, cwmasin=cwmas ) + + IF ( .false. ) THEN + write(6,*) 'nsslrun2: qc,max ccw = ',mpirank,maxval(qc_mp),maxval(nc_mp),sum(nc_mp) + IF ( mpirank == 1 ) THEN + DO k=1,nlev + DO i=1,ncol + IF ( qc_mp(i,k) > 1.e-6 .and. nc_mp(i,k) <= 1.e-9 ) THEN + write(6,*) 'i2,k,qc,nc,ccn = ',i,k,qc_mp(i,k),nc_mp(i,k),cccn_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + + deallocate( an ) + + IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN ! cn_mp = Max(0.0, nssl_qccn - Max(0.0,cccn)) DO k = 1,nlev DO i = 1,ncol - cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn(i,k)) ) + cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn_mp(i,k)) ) ! cn_mp(i,k) = Min(nssl_qccn, nssl_qccn - cccn(i,k) ) ENDDO ENDDO @@ -457,7 +687,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ! ENDDO ! ENDDO ELSE - cn_mp = cccn + cn_mp = cccn_mp ENDIF IF ( ntccna > 0 ) THEN ! cna_mp = cccna @@ -473,7 +703,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN CALL nssl_2mom_driver( & @@ -487,13 +717,13 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & QS=qs_mp, & QH=qh_mp, & QHL=qhl_mp, & - CCW=ccw, & - CRW=crw, & - CCI=cci, & - CSW=csw, & - CHW=chw, & - CHL=chl_mp, & - VHW=vh, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & VHL=vhl_mp, & cn=cn_mp, & ! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use @@ -511,12 +741,15 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & dbz = refl_10cm, & ! nssl_progn=.false., & diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & re_cloud=re_cloud_mp, & re_ice=re_ice_mp, & re_snow=re_snow_mp, & + re_rain=re_rain_mp, & has_reqc=has_reqc, & ! ala G. Thompson has_reqi=has_reqi, & ! ala G. Thompson has_reqs=has_reqs, & ! ala G. Thompson + has_reqr=has_reqr, & IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -537,13 +770,13 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & QH=qh_mp, & QHL=qhl_mp, & ! CCW=qnc_mp, & - CCW=ccw, & - CRW=crw, & - CCI=cci, & - CSW=csw, & - CHW=chw, & - CHL=chl_mp, & - VHW=vh, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & VHL=vhl_mp, & ! cn=cccn, & PII=prslk, & @@ -559,12 +792,15 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & dbz = refl_10cm, & ! nssl_progn=.false., & diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & re_cloud=re_cloud_mp, & re_ice=re_ice_mp, & re_snow=re_snow_mp, & + re_rain=re_rain_mp, & has_reqc=has_reqc, & ! ala G. Thompson has_reqi=has_reqi, & ! ala G. Thompson has_reqs=has_reqs, & ! ala G. Thompson + has_reqr=has_reqr, & IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -574,8 +810,8 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & DO i = 1,ncol - delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) - delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) + delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) ! this is liquid equivalent of all precip + delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) ! this is liquid equivalent of graupel delta_ice_mp(i) = delta_ice_mp(i) + xdelta_ice_mp(i) delta_snow_mp(i) = delta_snow_mp(i) + xdelta_snow_mp(i) ENDDO @@ -583,17 +819,17 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ENDDO - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN !cccn = Max(0.0, nssl_qccn - cn_mp ) DO k = 1,nlev DO i = 1,ncol ! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) - cccn(i,k) = nssl_qccn - cn_mp(i,k) + cccn_mp(i,k) = nssl_qccn - cn_mp(i,k) ENDDO ENDDO ELSE - cccn = cn_mp + cccn_mp = cn_mp ENDIF ! cccna = cna_mp ENDIF @@ -619,7 +855,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ENDIF write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) IF ( 1000.*maxval(qc_mp) > 0.5 .or. 1000.*maxval(qi_mp) > 0.09 .or. 1000.*maxval(qs_mp) > 0.1 ) THEN - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' DO k = 1,nlev write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, ccw(1,k)*rho(1,k)*1.e-6, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 @@ -633,10 +869,6 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ENDIF ENDIF - IF ( nssl_hail_on ) THEN - chl = chl_mp - vhl = vhl_mp - ENDIF !> - Convert dry mixing ratios to specific humidity/moist mixing ratios spechum = qv_mp/(1.0_kind_phys+qv_mp) @@ -646,8 +878,18 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & qi = qi_mp/(1.0_kind_phys+qv_mp) qs = qs_mp/(1.0_kind_phys+qv_mp) qh = qh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_ccn_on ) cccn = cccn_mp/(1.0_kind_phys+qv_mp) +! cccna = cccna_mp/(1.0_kind_phys+qv_mp) + ccw = nc_mp/(1.0_kind_phys+qv_mp) + crw = nr_mp/(1.0_kind_phys+qv_mp) + cci = ni_mp/(1.0_kind_phys+qv_mp) + csw = ns_mp/(1.0_kind_phys+qv_mp) + chw = nh_mp/(1.0_kind_phys+qv_mp) + vh = vh_mp/(1.0_kind_phys+qv_mp) IF ( nssl_hail_on ) THEN qhl = qhl_mp/(1.0_kind_phys+qv_mp) + chl = nhl_mp/(1.0_kind_phys+qv_mp) + vhl = vhl_mp/(1.0_kind_phys+qv_mp) ENDIF ELSE ! spechum = qv_mp ! /(1.0_kind_phys+qv_mp) @@ -656,13 +898,23 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & qi = qi_mp ! /(1.0_kind_phys+qv_mp) qs = qs_mp ! /(1.0_kind_phys+qv_mp) qh = qh_mp ! /(1.0_kind_phys+qv_mp) + IF ( nssl_ccn_on ) cccn = cccn_mp +! cccna = cccna_mp + ccw = nc_mp + crw = nr_mp + cci = ni_mp + csw = ns_mp + chw = nh_mp + vh = vh_mp IF ( nssl_hail_on ) THEN qhl = qhl_mp ! /(1.0_kind_phys+qv_mp) + chl = nhl_mp + vhl = vhl_mp ENDIF ENDIF -! write(0,*) 'mp_nsslg: done q' +! write(0,*) 'mp_nssl: done q' !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables ! "rain" in NSSL MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) @@ -673,27 +925,27 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & snow = max(0.0, delta_snow_mp/1000.0_kind_phys) rain = max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) -! write(0,*) 'mp_nsslg: done precip' +! write(0,*) 'mp_nssl: done precip' if (do_effective_radii) then ! Convert m to micron re_cloud = re_cloud_mp*1.0E6_kind_phys re_ice = re_ice_mp*1.0E6_kind_phys re_snow = re_snow_mp*1.0E6_kind_phys -! re_rain = 1.0E3_kind_phys + re_rain = re_rain_mp*1.0E6_kind_phys end if - IF ( ndebug > 1 ) write(0,*) 'mp_nsslg: end' + IF ( ndebug > 1 ) write(0,*) 'mp_nssl: end' - end subroutine mp_nsslg_run + end subroutine mp_nssl_run !>@} #if 0 -!! \section arg_table_mp_nsslg_finalize Argument Table -!! \htmlinclude mp_nsslg_finalize.html +!! \section arg_table_mp_nssl_finalize Argument Table +!! \htmlinclude mp_nssl_finalize.html !! #endif - subroutine mp_nsslg_finalize(errflg, errmsg) + subroutine mp_nssl_finalize(errflg, errmsg) implicit none character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -702,6 +954,6 @@ subroutine mp_nsslg_finalize(errflg, errmsg) errmsg = '' - end subroutine mp_nsslg_finalize + end subroutine mp_nssl_finalize -end module mp_nsslg +end module mp_nssl diff --git a/physics/mp_nsslg.meta b/physics/mp_nssl.meta similarity index 69% rename from physics/mp_nsslg.meta rename to physics/mp_nssl.meta index 95a11826e..78914eb91 100644 --- a/physics/mp_nsslg.meta +++ b/physics/mp_nssl.meta @@ -1,10 +1,10 @@ [ccpp-table-properties] - name = mp_nsslg + name = mp_nssl type = scheme dependencies = machine.F,module_mp_nssl_2mom.F90 [ccpp-arg-table] - name = mp_nsslg_init + name = mp_nssl_init type = scheme [ncol] standard_name = horizontal_loop_extent @@ -22,6 +22,39 @@ type = integer intent = in optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F +[threads] + standard_name = omp_threads + long_name = number of OpenMP threads available to scheme + units = count + dimensions = () + type = integer + intent = in + optional = F +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in + optional = F [mpicomm] standard_name = mpi_comm long_name = MPI communicator @@ -46,14 +79,6 @@ type = integer intent = in optional = F -[threads] - standard_name = omp_threads - long_name = number of OpenMP threads available to scheme - units = count - dimensions = () - type = integer - intent = in - optional = F [imp_physics] standard_name = flag_for_microphysics_scheme long_name = choice of microphysics scheme @@ -62,7 +87,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -70,14 +95,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [nssl_cccn] standard_name = nssl_ccn_concentration long_name = CCN concentration @@ -105,6 +122,14 @@ kind = kind_phys intent = in optional = F +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro @@ -113,27 +138,213 @@ type = logical intent = in optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro units = none dimensions = () - type = character - kind = len=* - intent = out + type = logical + intent = in optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) units = flag dimensions = () - type = integer - intent = out + type = logical + intent = in + optional = F +[spechum] + standard_name = water_vapor_specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qc] + standard_name = cloud_condensed_water_mixing_ratio + long_name = cloud water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qr] + standard_name = rain_water_mixing_ratio + long_name = rain water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qi] + standard_name = ice_water_mixing_ratio + long_name = ice water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qs] + standard_name = snow_water_mixing_ratio + long_name = snow water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qh] + standard_name = graupel_mixing_ratio + long_name = graupel mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qhl] + standard_name = hail_mixing_ratio + long_name = moist (dry+vapor, no condensates) mixing ratio of hail + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cccn] + standard_name = cloud_condensation_nuclei_number_concentration + long_name = number concentration of cloud condensation nuclei + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cccna] + standard_name = activated_cloud_condensation_nuclei_number_concentration + long_name = number concentration of activated cloud condensation nuclei + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ccw] + standard_name = cloud_droplet_number_concentration + long_name = cloud droplet number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[crw] + standard_name = rain_number_concentration + long_name = rain number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cci] + standard_name = ice_number_concentration + long_name = ice number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[csw] + standard_name = snow_number_concentration + long_name = snow number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[chw] + standard_name = graupel_number_concentration + long_name = graupel number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[chl] + standard_name = hail_number_concentration + long_name = hail number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[vh] + standard_name = graupel_volume + long_name = graupel particle volume + units = m3 kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[vhl] + standard_name = hail_volume + long_name = hail particle volume + units = m3 kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[csw_phys] + standard_name = snow_number_concentration_updated_by_physics + long_name = snow number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout optional = F ######################################################################## [ccpp-arg-table] - name = mp_nsslg_run + name = mp_nssl_run type = scheme [ncol] standard_name = horizontal_loop_extent @@ -169,6 +380,14 @@ kind = kind_phys intent = in optional = F +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F [spechum] standard_name = water_vapor_specific_humidity_updated_by_physics long_name = water vapor specific humidity @@ -480,6 +699,15 @@ kind = kind_phys intent = out optional = T +[re_rain] + standard_name = effective_radius_of_stratiform_cloud_rain_particle_in_um + long_name = effective radius of cloud rain particle in micrometers + units = um + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = T [imp_physics] standard_name = flag_for_microphysics_scheme long_name = choice of microphysics scheme @@ -488,7 +716,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -496,12 +724,12 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none dimensions = () - type = integer + type = logical intent = in optional = F [nssl_hail_on] @@ -556,7 +784,7 @@ ######################################################################## [ccpp-arg-table] - name = mp_nsslg_finalize + name = mp_nssl_finalize type = scheme [errmsg] standard_name = ccpp_error_message From e18f790af1df07cea0157cec177041c5750ebe41 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 1 Oct 2021 18:03:37 -0500 Subject: [PATCH 019/217] Fixed missing setting of save arrays for NSSL. --- physics/GFS_suite_interstitial.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 8fffe4d65..9fed6f964 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -671,10 +671,12 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & else if (imp_physics == imp_physics_nssl ) then do k=1,levs do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! ice - clw(i,k,2) = gq0(i,k,ntcw) ! water + clw(i,k,1) = gq0(i,k,ntiw) ! cloud ice + clw(i,k,2) = gq0(i,k,ntcw) ! cloud droplets enddo enddo + save_qi(:,:) = clw(:,:,1) + save_qc(:,:) = clw(:,:,2) elseif (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_mg .or. imp_physics == imp_physics_fer_hires) then do k=1,levs do i=1,im @@ -853,8 +855,8 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo enddo - if ( .true. .and. ( imp_physics == imp_physics_nssl ) ) then - liqm = con_pi/6.*1.e3*(40.e-6)**3 ! 4./3.*con_pi*1.e-12 + if ( imp_physics == imp_physics_nssl ) then + liqm = con_pi/6.*1.e3*(18.e-6)**3 ! 4./3.*con_pi*1.e-12 icem = con_pi/6.*1.e3*(120.e-6)**3 ! 4./3.*con_pi*3.2768*1.e-14*890. ! qccn = nssl_cccn/1.225 do k=1,levs From b565f5ff860b96be629783cd3365945aa81451f7 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 14 Oct 2021 20:28:27 -0500 Subject: [PATCH 020/217] Update to newer base code plus some cleanup of NSSL microphysics --- physics/GFS_DCNV_generic.F90 | 9 +- physics/GFS_DCNV_generic.meta | 32 +++++ physics/GFS_MP_generic.meta | 2 +- physics/GFS_PBL_generic.F90 | 6 +- physics/GFS_PBL_generic.meta | 24 ++-- physics/GFS_debug.F90 | 2 +- physics/GFS_rrtmg_pre.F90 | 14 +- physics/GFS_rrtmg_pre.meta | 14 +- physics/GFS_suite_interstitial.F90 | 9 +- physics/GFS_suite_interstitial.meta | 8 +- physics/maximum_hourly_diagnostics.meta | 2 +- physics/module_MYNNPBL_wrapper.meta | 2 +- physics/module_mp_nssl_2mom.F90 | 28 ++-- physics/mp_nssl.F90 | 20 +-- physics/mp_nssl.meta | 173 +++++++++++------------- physics/sfc_drv_ruc.F90 | 7 +- physics/sfc_drv_ruc.meta | 8 ++ 17 files changed, 204 insertions(+), 156 deletions(-) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index e7dec5ca1..fb807c3ca 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -19,7 +19,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc gu0, gv0, gt0, gq0, nsamftrac, ntqv, & save_u, save_v, save_t, save_q, clw, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, cscnv, satmedmf, trans_trac, ras, ntrac, & + ntgnc, nthl, nthnc, nthv, ntgv, & + cscnv, satmedmf, trans_trac, ras, ntrac, & dtidx, index_of_process_dcnv, errmsg, errflg) use machine, only: kind_phys @@ -27,7 +28,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc implicit none integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 @@ -71,7 +72,9 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & + n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntgv ) then tracers = tracers + 1 if(dtidx(100+n,index_of_process_dcnv)>0) then save_q(:,:,n) = clw(:,:,tracers) diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index c64e1fadb..5ab7d1928 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -263,6 +263,38 @@ type = integer intent = in optional = F +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index 18e399b43..57ef393a6 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -241,7 +241,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 28333fc2e..8fd351d7f 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -113,7 +113,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: cplchm, ltaerosol, nssl_hail_on, nssl_ccn_on + logical, intent(in) :: nssl_hail_on, nssl_ccn_on real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs @@ -413,10 +413,12 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, integer, parameter :: kp = kind_phys integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm, kdt integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires - integer, intent(in) :: imp_physics_nssl, nssl_ccn_on, nssl_hail_on + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_ccn_on, nssl_hail_on logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index baa45a0c3..a09512d54 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -208,7 +208,7 @@ intent = in optional = F [ntccn] - standard_name = index_for_cloud_condensation_nuclei_number_concentration + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration units = index dimensions = () @@ -216,7 +216,7 @@ intent = in optional = F [nthl] - standard_name = index_for_hail + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array long_name = tracer index for hail units = index dimensions = () @@ -224,7 +224,7 @@ intent = in optional = F [nthnc] - standard_name = index_for_hail_number_concentration + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array long_name = tracer index for hail number concentration units = index dimensions = () @@ -232,7 +232,7 @@ intent = in optional = F [ntgv] - standard_name = index_for_graupel_volume + standard_name = index_of_graupel_volume_in_tracer_concentration_array long_name = tracer index for graupel particle volume units = index dimensions = () @@ -240,7 +240,7 @@ intent = in optional = F [nthv] - standard_name = index_for_hail_volume + standard_name = index_of_hail_volume_in_tracer_concentration_array long_name = tracer index for hail particle volume units = index dimensions = () @@ -304,7 +304,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () @@ -693,7 +693,7 @@ intent = in optional = F [ntccn] - standard_name = index_for_cloud_condensation_nuclei_number_concentration + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration units = index dimensions = () @@ -701,7 +701,7 @@ intent = in optional = F [nthl] - standard_name = index_for_hail + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array long_name = tracer index for hail units = index dimensions = () @@ -709,7 +709,7 @@ intent = in optional = F [nthnc] - standard_name = index_for_hail_number_concentration + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array long_name = tracer index for hail number concentration units = index dimensions = () @@ -717,7 +717,7 @@ intent = in optional = F [ntgv] - standard_name = index_for_graupel_volume + standard_name = index_of_graupel_volume_in_tracer_concentration_array long_name = tracer index for graupel particle volume units = index dimensions = () @@ -725,7 +725,7 @@ intent = in optional = F [nthv] - standard_name = index_for_hail_volume + standard_name = index_of_hail_volume_in_tracer_concentration_array long_name = tracer index for hail particle volume units = index dimensions = () @@ -789,7 +789,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index deb88458b..ff37ee34e 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1388,7 +1388,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clxss ', Interstitial%clxss ) end if ! GFDL and Thompson MP - if (Model%imp_physics == Model%imp_physics_gfdl .or. Model%imp_physics == Model%imp_physics_thompson) then + if (Model%imp_physics == Model%imp_physics_gfdl .or. Model%imp_physics == Model%imp_physics_thompson .or. Model%imp_physics == Model%imp_physics_nssl) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%graupelmp ', Interstitial%graupelmp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%icemp ', Interstitial%icemp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rainmp ', Interstitial%rainmp ) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 10ba643bd..99dc215b3 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,9 +18,9 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, first_time_step, & - imp_physics,imp_physics_nssl, & + imp_physics,imp_physics_nssl, nssl_ccn_on, nssl_invertccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & imp_physics_fer_hires, julian, yearlen, lndp_var_list, lsswr, lslwr, & @@ -78,7 +78,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & make_DropletNumber, & make_RainNumber - use module_mp_nssl_2mom, only: calc_eff_radius, calcnfromq, na +! use module_mp_nssl_2mom, only: calc_eff_radius, calcnfromq, na implicit none @@ -686,11 +686,13 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif if_thompson if (imp_physics == imp_physics_nssl) then ! write(6,*) 'rrtm_pre: set qx_mp for NSSL',ntlnc,ntinc,ntsnc,ntrnc + IF ( .not. effr_in ) THEN do k=1,LMK ! IF ( me == mpiroot ) write(6,*) 'k,rho: ',k,rho(1,k) do i=1,IM qvs = qgrs(i,k,ntqv) qv_mp (i,k) = qvs/(1.-qvs) + rho (i,k) = con_eps*plyr(i,k)*100./(con_rd*tlyr(i,k)*(qv_mp(i,k)+con_eps)) qc_mp (i,k) = tracer1(i,k,ntcw)/(1.-qvs) qi_mp (i,k) = tracer1(i,k,ntiw)/(1.-qvs) qs_mp (i,k) = tracer1(i,k,ntsw)/(1.-qvs) @@ -702,6 +704,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & IF ( nssl_ccn_on ) cccn_mp(i,k) = tracer1(i,k,ntccn)/(1.-qvs) enddo enddo + ENDIF ! write(6,*) 'rrtmg_pre: max qctrac,qc,qcphy,nctrac,ccw,ccwphy: ',maxval(qc_mp),maxval(qc), & ! maxval(qc_phys),maxval(nc_mp),maxval(ccw),maxval(ccw_phys) ! write(6,*) 'rrtmg_pre: max ni,ns,nr = ',maxval(ni_mp),maxval(ns_mp),maxval(nr_mp) @@ -803,8 +806,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & elseif (imp_physics == imp_physics_nssl ) then ! NSSL MP cldcov = 0.0 if(effr_in) then -! if( kdt > 2 ) then -! IF ( .true. .or. maxval(nc_mp) >= 1.e-20 ) THEN do k=1,lm k1 = k + kd do i=1,im @@ -815,6 +816,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo else +#if 0 ! calculate radii here, but something is not right with incoming number concentrations ! IF ( .true. .and. first_time_step ) THEN IF ( ( maxval(qc_mp) > 1.e-11 .and. maxval(nc_mp) < 1.e-5 ) .or. & @@ -905,7 +907,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & effrs_inout(i,k) = effrs(i,k1) enddo enddo - +#endif endif elseif (imp_physics == imp_physics_thompson) then ! Thompson MP diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 2dfe22f8d..40d07f1a9 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1,7 +1,7 @@ [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 = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,module_mp_radar.F90,module_mp_thompson.F90,module_mp_nssl_2mom.F90 dependencies = module_mp_thompson_make_number_concentrations.F90,physcons.F90,physparam.f,radcons.f90,radiation_aerosols.f dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90,radiation_cloud_overlap.F90 @@ -162,7 +162,7 @@ intent = in optional = F [ntrnc] - standard_name = index_for_rain_number_concentration + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array long_name = tracer index for rain number concentration units = index dimensions = () @@ -170,7 +170,7 @@ intent = in optional = F [ntsnc] - standard_name = index_for_snow_number_concentration + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array long_name = tracer index for snow number concentration units = index dimensions = () @@ -202,7 +202,7 @@ intent = in optional = F [nthl] - standard_name = index_for_hail + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array long_name = tracer index for hail units = index dimensions = () @@ -210,7 +210,7 @@ intent = in optional = F [ntccn] - standard_name = index_for_cloud_condensation_nuclei_number_concentration + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration units = index dimensions = () @@ -298,7 +298,7 @@ intent = in optional = F [first_time_step] - standard_name = flag_for_first_time_step + standard_name = flag_for_first_timestep long_name = flag for first time step for time integration loop (cold/warmstart) units = flag dimensions = () @@ -314,7 +314,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 9fed6f964..cdc1a54ac 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -713,12 +713,11 @@ end subroutine GFS_suite_interstitial_4_finalize !! \htmlinclude GFS_suite_interstitial_4_run.html !! subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & - ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_nssl, nssl_invertccn, nssl_ccn_on, nssl_invertccn, & + ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl, nssl_invertccn, nssl_ccn_on, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & - qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) - otsptflag, ntracp1, errmsg, errflg) + qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, ntracp1, errmsg, errflg) use machine, only: kind_phys use module_mp_nssl_2mom, only: qccn @@ -732,7 +731,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr logical, intent(in) :: otsptflag(1:ntracp1)! on/off switch for tracer transport by updraft and integer, intent(in) :: ntracp1 integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & - ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl logical, intent(in) :: ltaerosol, convert_dry_rho diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index cd31f8619..6c2767f66 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_rad_reset type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90,module_mp_nssl_2mom.F90 ######################################################################## [ccpp-arg-table] @@ -1428,7 +1428,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () @@ -1832,7 +1832,7 @@ intent = in optional = F [ntccn] - standard_name = index_for_cloud_condensation_nuclei_number_concentration + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration units = index dimensions = () @@ -1888,7 +1888,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index fd764dc1d..11afbe9cd 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -72,7 +72,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index a35ab4e7b..9830c4b03 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1438,7 +1438,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 0a8532de1..65fecae7e 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1,7 +1,7 @@ !WRF:MODEL_LAYER:PHYSICS -! prepocessed on "Sep 30 2021" at "11:13:44" +! prepocessed on "Oct 6 2021" at "17:14:05" @@ -214,7 +214,7 @@ MODULE module_mp_nssl_2mom integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) ! =2 turn on for graupel density less than 300. only integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) - integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band + integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband ! microphysics real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params @@ -1248,7 +1248,7 @@ SUBROUTINE nssl_2mom_init( & - IF ( .true. ) THEN ! set to true to enable internal namelist read + IF ( .false. ) THEN ! set to true to enable internal namelist read open(15,file='input.nml',status='old',form='formatted',action='read') rewind(15) read(15,NML=nssl_mp_params,iostat=istat) @@ -2832,7 +2832,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present(has_reqr) .and. present( re_rain ) ) THEN IF ( has_reqr /= 0 ) THEN - re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t3(ix,1,kz), 2999.E-6)) + DO kz = kts,kte + DO ix = its,ite + re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t4(ix,1,kz), 2999.E-6)) + ENDDO + ENDDO ENDIF ENDIF @@ -3786,13 +3790,17 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO n = 1,ndfall - IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN + IF ( ( il /= lc .and. il /= li ) .and. do_accurate_sedimentation .and. n .ge. 2 .and. & + ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN ! ! zero the precip flux arrays (2d) ! ! xvt(:,:,:,il) = 0.0 dummy = 0.d0 + + IF ( il == lh .or. il == lr ) xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & & xvt, rhovtzx, & & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & @@ -6395,7 +6403,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! DO il = lc,lhab ! IF ( il .ne. lr ) THEN DO mgs = 1,ngscnt - vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + IF ( ildo == 0 .or. ildo == lc ) THEN + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + ENDIF IF ( li .gt. 1 ) THEN ! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) ! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) @@ -7774,8 +7784,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & if (lsw .gt. 1) THEN qxw = an(ix,jy,kz,lsw) qxw1 = 0.0 - ELSEIF ( iusewetsnow == 1 .and. temk(ix,jy,kz) .gt. tfr+1. .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) & - & .and. an(ix,jy,kz,lr) > qsmin) THEN + ELSEIF ( ( iusewetsnow == 1 .or. iusewetsnow == 3) .and. temk(ix,jy,kz) .gt. tfr+1. & + & .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) .and. an(ix,jy,kz,lr) > qsmin) THEN qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr)) qxw1 = qxw ENDIF @@ -7786,7 +7796,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN ! IF ( .true. ) THEN - IF ( qxw > qsmin ) THEN ! old version + IF ( qxw > qsmin .or. iusewetsnow >= 2) THEN ! old version ! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & ! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 84531244e..2e90dfaab 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -24,13 +24,13 @@ module mp_nssl !! \htmlinclude mp_nssl_init.html !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & - mpicomm, mpirank, mpiroot, & + mpirank, mpiroot, & imp_physics, imp_physics_nssl, & nssl_cccn, nssl_alphah, nssl_alphahl, & nssl_ccn_on, nssl_hail_on, nssl_invertccn, first_time_step, & spechum, qc, qr, qi, qs, qh, qhl, & - cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl, & - csw_phys ) + cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl ) + use module_mp_nssl_2mom, only: nssl_2mom_init, calcnfromq, na use physcons, only: con_rd @@ -44,7 +44,6 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent(in) :: threads logical, intent(in) :: restart - integer, intent(in) :: mpicomm integer, intent(in) :: mpirank integer, intent(in) :: mpiroot integer, intent(in) :: imp_physics @@ -72,8 +71,6 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & real(kind_phys), intent(inout) :: vh(1:ncol,1:nlev) ! graupel volume real(kind_phys), intent(inout) :: vhl(:,:) ! (1:ncol,1:nlev) ! hail volume - real(kind_phys), intent(inout) :: csw_phys(1:ncol,1:nlev) - ! State variables and timestep information real(kind_phys), intent(inout) :: tgrs(1:ncol,1:nlev) real(kind_phys), intent(in ) :: prsl(1:ncol,1:nlev) @@ -188,6 +185,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ENDIF ! .not. is_initialized +#if 0 ! IF ( is_initialized .and. ((.not. first_time_step) .or. restart ) ) THEN ! return ! ENDIF @@ -260,7 +258,6 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & cccn = cccn_mp ENDIF ENDIF - csw_phys = csw ! qs = 0 ! qi = 0 @@ -277,6 +274,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & deallocate( an ) +#endif return @@ -425,7 +423,7 @@ 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 = 300. ! 600. ! 120. + real, parameter :: dtpmax = 150. ! 300. ! 600. ! 120. real(kind_phys) :: dtptmp integer, parameter :: ndebug = 0 logical, parameter :: convertdry = .true. @@ -643,6 +641,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & itimestep = 2 ENDIF + IF ( .false. ) THEN ! incoming droplet field may have some inconsistent number concentrations (e.g., from PBL) ! so check for that, otherwise mass may be zapped into vapor allocate( an(ncol,1,nlev,na) ) @@ -670,6 +669,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & deallocate( an ) + ENDIF IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN @@ -696,7 +696,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ENDIF ENDIF - + IF ( .true. ) THEN DO n = 1,ntmul itimestep = itimestep + 1 @@ -817,6 +817,8 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ENDDO ENDDO + + ENDIF IF ( nssl_ccn_on ) THEN diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 78914eb91..772ba406b 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -7,15 +7,15 @@ name = mp_nssl_init type = scheme [ncol] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent + standard_name = horizontal_dimension + long_name = horizontal dimension units = count dimensions = () type = integer intent = in optional = F [nlev] - standard_name = vertical_dimension + standard_name = vertical_layer_dimension long_name = number of vertical levels units = count dimensions = () @@ -40,7 +40,7 @@ intent = out optional = F [threads] - standard_name = omp_threads + standard_name = number_of_openmp_threads long_name = number of OpenMP threads available to scheme units = count dimensions = () @@ -55,14 +55,6 @@ type = logical intent = in optional = F -[mpicomm] - standard_name = mpi_comm - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in - optional = F [mpirank] standard_name = mpi_rank long_name = current MPI-rank @@ -80,7 +72,7 @@ intent = in optional = F [imp_physics] - standard_name = flag_for_microphysics_scheme + standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme units = flag dimensions = () @@ -88,7 +80,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () @@ -147,7 +139,7 @@ intent = in optional = F [first_time_step] - standard_name = flag_for_first_time_step + standard_name = flag_for_first_timestep long_name = flag for first time step for time integration loop (cold/warmstart) units = flag dimensions = () @@ -155,46 +147,46 @@ intent = in optional = F [spechum] - standard_name = water_vapor_specific_humidity + standard_name = specific_humidity long_name = water vapor specific humidity units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [qc] - standard_name = cloud_condensed_water_mixing_ratio + standard_name = cloud_liquid_water_mixing_ratio long_name = cloud water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [qr] - standard_name = rain_water_mixing_ratio + standard_name = rain_mixing_ratio long_name = rain water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [qi] - standard_name = ice_water_mixing_ratio + standard_name = cloud_ice_mixing_ratio long_name = ice water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [qs] - standard_name = snow_water_mixing_ratio + standard_name = snow_mixing_ratio long_name = snow water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -203,7 +195,7 @@ standard_name = graupel_mixing_ratio long_name = graupel mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -212,7 +204,7 @@ standard_name = hail_mixing_ratio long_name = moist (dry+vapor, no condensates) mixing ratio of hail units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -221,7 +213,7 @@ standard_name = cloud_condensation_nuclei_number_concentration long_name = number concentration of cloud condensation nuclei units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -230,61 +222,61 @@ standard_name = activated_cloud_condensation_nuclei_number_concentration long_name = number concentration of activated cloud condensation nuclei units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [ccw] - standard_name = cloud_droplet_number_concentration + standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air long_name = cloud droplet number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [crw] - standard_name = rain_number_concentration + standard_name = mass_number_concentration_of_rain_water_in_air long_name = rain number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [cci] - standard_name = ice_number_concentration + standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air long_name = ice number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [csw] - standard_name = snow_number_concentration + standard_name = mass_number_concentration_of_snow_in_air long_name = snow number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [chw] - standard_name = graupel_number_concentration + standard_name = mass_number_concentration_of_graupel_in_air long_name = graupel number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [chl] - standard_name = hail_number_concentration + standard_name = mass_number_concentration_of_hail_in_air long_name = hail number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -293,7 +285,7 @@ standard_name = graupel_volume long_name = graupel particle volume units = m3 kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -302,7 +294,7 @@ standard_name = hail_volume long_name = hail particle volume units = m3 kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -311,36 +303,29 @@ standard_name = air_temperature long_name = model layer mean temperature units = K - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [prslk] - standard_name = dimensionless_exner_function_at_model_layers + standard_name = dimensionless_exner_function long_name = dimensionless Exner function at model layer centers units = none - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + intent = in + optional = F [prsl] standard_name = air_pressure long_name = mean layer pressure units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in optional = F -[csw_phys] - standard_name = snow_number_concentration_updated_by_physics - long_name = snow number concentration - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F ######################################################################## [ccpp-arg-table] @@ -355,7 +340,7 @@ intent = in optional = F [nlev] - standard_name = vertical_dimension + standard_name = vertical_layer_dimension long_name = number of vertical levels units = count dimensions = () @@ -372,7 +357,7 @@ intent = in optional = F [con_rd] - standard_name = gas_constant_dry_air + standard_name = gas_constant_of_dry_air long_name = ideal gas constant for dry air units = J kg-1 K-1 dimensions = () @@ -389,7 +374,7 @@ intent = in optional = F [spechum] - standard_name = water_vapor_specific_humidity_updated_by_physics + standard_name = specific_humidity_of_new_state long_name = water vapor specific humidity units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -398,7 +383,7 @@ intent = inout optional = F [qc] - standard_name = cloud_condensed_water_mixing_ratio_updated_by_physics + standard_name = cloud_liquid_water_mixing_ratio_of_new_state long_name = cloud water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -407,7 +392,7 @@ intent = inout optional = F [qr] - standard_name = rain_water_mixing_ratio_updated_by_physics + standard_name = rain_mixing_ratio_of_new_state long_name = rain water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -416,7 +401,7 @@ intent = inout optional = F [qi] - standard_name = ice_water_mixing_ratio_updated_by_physics + standard_name = cloud_ice_mixing_ratio_of_new_state long_name = ice water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -425,7 +410,7 @@ intent = inout optional = F [qs] - standard_name = snow_water_mixing_ratio_updated_by_physics + standard_name = snow_mixing_ratio_of_new_state long_name = snow water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -434,7 +419,7 @@ intent = inout optional = F [qh] - standard_name = graupel_mixing_ratio_updated_by_physics + standard_name = graupel_mixing_ratio_of_new_state long_name = graupel mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -443,7 +428,7 @@ intent = inout optional = F [qhl] - standard_name = hail_mixing_ratio_updated_by_physics + standard_name = hail_mixing_ratio_of_new_state long_name = moist (dry+vapor, no condensates) mixing ratio of hail updated by physics units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -452,7 +437,7 @@ intent = inout optional = F [cccn] - standard_name = cloud_condensation_nuclei_number_concentration_updated_by_physics + standard_name = cloud_condensation_nuclei_number_concentration_of_new_state long_name = number concentration of cloud condensation nuclei updated by physics units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -461,7 +446,7 @@ intent = inout optional = F [cccna] - standard_name = activated_cloud_condensation_nuclei_number_concentration_updated_by_physics + standard_name = activated_cloud_condensation_nuclei_number_concentration_of_new_state long_name = number concentration of activated cloud condensation nuclei updated by physics units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -470,7 +455,7 @@ intent = inout optional = F [ccw] - standard_name = cloud_droplet_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air_of_new_state long_name = cloud droplet number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -479,7 +464,7 @@ intent = inout optional = F [crw] - standard_name = rain_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_rain_of_new_state long_name = rain number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -488,7 +473,7 @@ intent = inout optional = F [cci] - standard_name = ice_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air_of_new_state long_name = ice number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -497,7 +482,7 @@ intent = inout optional = F [csw] - standard_name = snow_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_snow_of_new_state long_name = snow number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -506,7 +491,7 @@ intent = inout optional = F [chw] - standard_name = graupel_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_graupel_of_new_state long_name = graupel number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -515,7 +500,7 @@ intent = inout optional = F [chl] - standard_name = hail_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_hail_of_new_state long_name = hail number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -524,7 +509,7 @@ intent = inout optional = F [vh] - standard_name = graupel_volume_updated_by_physics + standard_name = graupel_volume_of_new_state long_name = graupel particle volume units = m3 kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -533,7 +518,7 @@ intent = inout optional = F [vhl] - standard_name = hail_volume_updated_by_physics + standard_name = hail_volume_of_new_state long_name = hail particle volume units = m3 kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -542,21 +527,23 @@ intent = inout optional = F [tgrs] - standard_name = air_temperature_updated_by_physics + standard_name = air_temperature_of_new_state long_name = model layer mean temperature units = K - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout optional = F [prslk] - standard_name = dimensionless_exner_function_at_model_layers + standard_name = dimensionless_exner_function long_name = dimensionless Exner function at model layer centers units = none dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + intent = in + optional = F [prsl] standard_name = air_pressure long_name = mean layer pressure @@ -576,7 +563,7 @@ intent = in optional = F [omega] - standard_name = omega + standard_name = lagrangian_tendency_of_air_pressure long_name = layer mean vertical velocity units = Pa s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -585,7 +572,7 @@ intent = in optional = F [dtp] - standard_name = time_step_for_physics + standard_name = timestep_for_physics long_name = physics timestep units = s dimensions = () @@ -665,7 +652,7 @@ intent = in optional = F [first_time_step] - standard_name = flag_for_first_time_step + standard_name = flag_for_first_timestep long_name = flag for first time step for time integration loop (cold/warmstart) units = flag dimensions = () @@ -673,34 +660,34 @@ intent = in optional = F [re_cloud] - standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle_in_um + standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle long_name = eff. radius of cloud liquid water particle in micrometer units = um - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = T [re_ice] - standard_name = effective_radius_of_stratiform_cloud_ice_particle_in_um + standard_name = effective_radius_of_stratiform_cloud_ice_particle long_name = eff. radius of cloud ice water particle in micrometer units = um dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = T [re_snow] - standard_name = effective_radius_of_stratiform_cloud_snow_particle_in_um + standard_name = effective_radius_of_stratiform_cloud_snow_particle long_name = effective radius of cloud snow particle in micrometer units = um dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = T [re_rain] - standard_name = effective_radius_of_stratiform_cloud_rain_particle_in_um + standard_name = effective_radius_of_stratiform_cloud_rain_particle long_name = effective radius of cloud rain particle in micrometers units = um dimensions = (horizontal_loop_extent,vertical_dimension) @@ -709,7 +696,7 @@ intent = inout optional = T [imp_physics] - standard_name = flag_for_microphysics_scheme + standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme units = flag dimensions = () @@ -717,7 +704,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () @@ -749,7 +736,7 @@ intent = in optional = F [ntccn] - standard_name = index_for_cloud_condensation_nuclei_number_concentration + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration units = index dimensions = () @@ -757,7 +744,7 @@ intent = in optional = F [ntccna] - standard_name = index_for_activated_cloud_condensation_nuclei_number_concentration + standard_name = index_of_activated_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for activated cloud condensation nuclei number concentration units = index dimensions = () diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index e426424a8..c72b4c908 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -320,6 +320,7 @@ end subroutine lsm_ruc_finalize subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & + & imp_physics_nssl, & & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, zs, & & t1, q1, qc, stype, vtype, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, lake, & @@ -371,7 +372,8 @@ subroutine lsm_ruc_run & ! inputs integer, intent(in) :: me, master integer, intent(in) :: im, nlev, iter, lsoil_ruc, lsoil, kdt, isot, ivegsrc integer, intent(in) :: lsm_ruc, lsm - integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson + integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl real (kind=kind_phys), dimension(:), intent(in) :: & & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & @@ -755,7 +757,8 @@ subroutine lsm_ruc_run & ! inputs ! Set flag for mixed phase precipitation depending on microphysics scheme. ! For GFDL and Thompson, srflag is fraction of frozen precip for convective+explicit precip. - if (imp_physics==imp_physics_gfdl .or. imp_physics==imp_physics_thompson) then + if (imp_physics==imp_physics_gfdl .or. imp_physics==imp_physics_thompson .or. & + imp_physics == imp_physics_nssl) then frpcpn = .true. else frpcpn = .false. diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index c793b5b9a..c6ffc1e36 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -688,6 +688,14 @@ type = integer intent = in optional = F +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F [do_mynnsfclay] standard_name = flag_for_mellor_yamada_nakanishi_niino_surface_layer_scheme long_name = flag to activate MYNN surface layer From 3b7b1394f437957c84830780b76563d52520d1fd Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 14 Oct 2021 22:19:05 -0500 Subject: [PATCH 021/217] Made IF test on tracer indices in post_run consistent with pre_run --- physics/GFS_DCNV_generic.F90 | 10 +++++++--- physics/GFS_DCNV_generic.meta | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 39 insertions(+), 3 deletions(-) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index fb807c3ca..a9e0ba7e0 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -114,7 +114,8 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & rainc, cldwrk, upd_mf, dwn_mf, det_mf, dtend, dtidx, index_of_process_dcnv, & index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv, gq0, save_q, & cnvw, cnvc, cnvw_phy_f3d, cnvc_phy_f3d, flag_for_dcnv_generic_tend, & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, ntrac,clw, & + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & + ntgnc, nthl, nthnc, nthv, ntgv, ntrac,clw, & satmedmf, trans_trac, errmsg, errflg) @@ -143,7 +144,8 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & real(kind=kind_phys), dimension(:,:,:), intent(inout) :: dtend integer, intent(in) :: dtidx(:,:), index_of_process_dcnv, index_of_temperature, & index_of_x_wind, index_of_y_wind, ntqv - integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc + integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & + ntgnc, nthl, nthnc, nthv, ntgv, ntrac real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw @@ -208,7 +210,9 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & + n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntgv ) then tracers = tracers + 1 idtend = dtidx(100+n,index_of_process_dcnv) if(idtend>0) then diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index 5ab7d1928..26ab49097 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -806,6 +806,38 @@ type = integer intent = in optional = F +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers From 7e419472ade401f8575f101f13aed204c8333d56 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 15 Oct 2021 20:00:26 -0500 Subject: [PATCH 022/217] Switched 'vertical_dimension' to 'vertical_layer_dimension' --- physics/mp_nssl.meta | 88 ++++++++++++++++++++++---------------------- 1 file changed, 44 insertions(+), 44 deletions(-) diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 772ba406b..dbfdfa506 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -150,7 +150,7 @@ standard_name = specific_humidity long_name = water vapor specific humidity units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -159,7 +159,7 @@ 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_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -168,7 +168,7 @@ standard_name = rain_mixing_ratio long_name = rain water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -177,7 +177,7 @@ 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_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -186,7 +186,7 @@ standard_name = snow_mixing_ratio long_name = snow water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -195,7 +195,7 @@ standard_name = graupel_mixing_ratio long_name = graupel mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -204,7 +204,7 @@ standard_name = hail_mixing_ratio long_name = moist (dry+vapor, no condensates) mixing ratio of hail units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -213,7 +213,7 @@ standard_name = cloud_condensation_nuclei_number_concentration long_name = number concentration of cloud condensation nuclei units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -222,7 +222,7 @@ standard_name = activated_cloud_condensation_nuclei_number_concentration long_name = number concentration of activated cloud condensation nuclei units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -231,7 +231,7 @@ 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_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -240,7 +240,7 @@ standard_name = mass_number_concentration_of_rain_water_in_air long_name = rain number concentration units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -249,7 +249,7 @@ standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air long_name = ice number concentration units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -258,7 +258,7 @@ standard_name = mass_number_concentration_of_snow_in_air long_name = snow number concentration units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -267,7 +267,7 @@ standard_name = mass_number_concentration_of_graupel_in_air long_name = graupel number concentration units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -276,7 +276,7 @@ standard_name = mass_number_concentration_of_hail_in_air long_name = hail number concentration units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -285,7 +285,7 @@ standard_name = graupel_volume long_name = graupel particle volume units = m3 kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -294,7 +294,7 @@ standard_name = hail_volume long_name = hail particle volume units = m3 kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -303,7 +303,7 @@ standard_name = air_temperature long_name = model layer mean temperature units = K - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -312,7 +312,7 @@ standard_name = dimensionless_exner_function long_name = dimensionless Exner function at model layer centers units = none - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -321,7 +321,7 @@ standard_name = air_pressure long_name = mean layer pressure units = Pa - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -377,7 +377,7 @@ standard_name = specific_humidity_of_new_state long_name = water vapor specific humidity units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -386,7 +386,7 @@ standard_name = cloud_liquid_water_mixing_ratio_of_new_state long_name = cloud water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -395,7 +395,7 @@ standard_name = rain_mixing_ratio_of_new_state long_name = rain water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -404,7 +404,7 @@ standard_name = cloud_ice_mixing_ratio_of_new_state long_name = ice water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -413,7 +413,7 @@ standard_name = snow_mixing_ratio_of_new_state long_name = snow water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -422,7 +422,7 @@ standard_name = graupel_mixing_ratio_of_new_state long_name = graupel mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -431,7 +431,7 @@ standard_name = hail_mixing_ratio_of_new_state long_name = moist (dry+vapor, no condensates) mixing ratio of hail updated by physics units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -440,7 +440,7 @@ standard_name = cloud_condensation_nuclei_number_concentration_of_new_state long_name = number concentration of cloud condensation nuclei updated by physics units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -449,7 +449,7 @@ standard_name = activated_cloud_condensation_nuclei_number_concentration_of_new_state long_name = number concentration of activated cloud condensation nuclei updated by physics units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -458,7 +458,7 @@ standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air_of_new_state long_name = cloud droplet number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -467,7 +467,7 @@ standard_name = mass_number_concentration_of_rain_of_new_state long_name = rain number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -476,7 +476,7 @@ standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air_of_new_state long_name = ice number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -485,7 +485,7 @@ standard_name = mass_number_concentration_of_snow_of_new_state long_name = snow number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -494,7 +494,7 @@ standard_name = mass_number_concentration_of_graupel_of_new_state long_name = graupel number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -503,7 +503,7 @@ standard_name = mass_number_concentration_of_hail_of_new_state long_name = hail number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -512,7 +512,7 @@ standard_name = graupel_volume_of_new_state long_name = graupel particle volume units = m3 kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -521,7 +521,7 @@ standard_name = hail_volume_of_new_state long_name = hail particle volume units = m3 kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -539,7 +539,7 @@ standard_name = dimensionless_exner_function long_name = dimensionless Exner function at model layer centers units = none - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -548,7 +548,7 @@ standard_name = air_pressure long_name = mean layer pressure units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -566,7 +566,7 @@ standard_name = lagrangian_tendency_of_air_pressure long_name = layer mean vertical velocity units = Pa s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -638,7 +638,7 @@ standard_name = radar_reflectivity_10cm long_name = instantaneous refl_10cm units = dBZ - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = out @@ -672,7 +672,7 @@ standard_name = effective_radius_of_stratiform_cloud_ice_particle long_name = eff. radius of cloud ice water particle in micrometer units = um - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -681,7 +681,7 @@ standard_name = effective_radius_of_stratiform_cloud_snow_particle long_name = effective radius of cloud snow particle in micrometer units = um - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -690,7 +690,7 @@ standard_name = effective_radius_of_stratiform_cloud_rain_particle long_name = effective radius of cloud rain particle in micrometers units = um - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout From 7e38a906eb3288bae736ef1bc58154db13c3516d Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 15 Oct 2021 20:37:28 -0500 Subject: [PATCH 023/217] Added convert_dry_rho flag --- physics/mp_nssl.F90 | 11 ++++++----- physics/mp_nssl.meta | 16 ++++++++++++++++ 2 files changed, 22 insertions(+), 5 deletions(-) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 2e90dfaab..754b99ca2 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -25,7 +25,7 @@ module mp_nssl !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & mpirank, mpiroot, & - imp_physics, imp_physics_nssl, & + imp_physics, imp_physics_nssl, convert_dry_rho, & nssl_cccn, nssl_alphah, nssl_alphahl, & nssl_ccn_on, nssl_hail_on, nssl_invertccn, first_time_step, & spechum, qc, qr, qi, qs, qh, qhl, & @@ -53,6 +53,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & logical, intent(in) :: first_time_step ! Hydrometeors + logical, intent(in ) :: convert_dry_rho real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) real(kind_phys), intent(inout) :: qc(1:ncol,1:nlev) real(kind_phys), intent(inout) :: qr(1:ncol,1:nlev) @@ -294,7 +295,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, & re_cloud, re_ice, re_snow, re_rain, & - imp_physics, & + imp_physics, convert_dry_rho, & imp_physics_nssl, nssl_ccn_on, & nssl_hail_on, nssl_invertccn, ntccn, ntccna, & errflg, errmsg) @@ -307,6 +308,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & real(kind_phys), intent(in ) :: con_rd integer, intent(in) :: mpirank ! Hydrometeors + logical, intent(in ) :: convert_dry_rho real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) real(kind_phys), intent(inout) :: cccn(:,:) ! (1:ncol,1:nlev) real(kind_phys), intent(inout) :: cccna(:,:) ! (1:ncol,1:nlev) @@ -426,7 +428,6 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & real, parameter :: dtpmax = 150. ! 300. ! 600. ! 120. real(kind_phys) :: dtptmp integer, parameter :: ndebug = 0 - logical, parameter :: convertdry = .true. logical :: invertccn real :: cwmas @@ -453,7 +454,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & !> - Convert specific humidity/moist mixing ratios to dry mixing ratios ! NOTE: Implied loops! qv_mp = spechum/(1.0_kind_phys-spechum) - IF ( convertdry ) THEN + IF ( convert_dry_rho ) THEN qc_mp = qc/(1.0_kind_phys-spechum) qr_mp = qr/(1.0_kind_phys-spechum) qi_mp = qi/(1.0_kind_phys-spechum) @@ -874,7 +875,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & !> - Convert dry mixing ratios to specific humidity/moist mixing ratios spechum = qv_mp/(1.0_kind_phys+qv_mp) - IF ( convertdry ) THEN + IF ( convert_dry_rho ) THEN qc = qc_mp/(1.0_kind_phys+qv_mp) qr = qr_mp/(1.0_kind_phys+qv_mp) qi = qi_mp/(1.0_kind_phys+qv_mp) diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index dbfdfa506..1ec3d03e4 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -79,6 +79,14 @@ type = integer intent = in optional = F +[convert_dry_rho] + standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air + long_name = flag for converting hydrometeors from moist to dry air + units = flag + dimensions = () + type = logical + intent = in + optional = F [imp_physics_nssl] standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme @@ -703,6 +711,14 @@ type = integer intent = in optional = F +[convert_dry_rho] + standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air + long_name = flag for converting hydrometeors from moist to dry air + units = flag + dimensions = () + type = logical + intent = in + optional = F [imp_physics_nssl] standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme From b17240ad2709f357b396152c3749acb92f39da15 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Mon, 18 Oct 2021 23:01:12 -0500 Subject: [PATCH 024/217] Removed some commented code; pass in physical constants to init routine instead of using physcons module --- physics/GFS_rrtmg_pre.F90 | 102 +----------- physics/GFS_rrtmg_pre.meta | 2 +- physics/module_mp_nssl_2mom.F90 | 284 +++++++------------------------- physics/mp_nssl.F90 | 12 +- physics/mp_nssl.meta | 72 ++++++++ 5 files changed, 143 insertions(+), 329 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 99dc215b3..35ea44203 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -78,8 +78,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & make_DropletNumber, & make_RainNumber -! use module_mp_nssl_2mom, only: calc_eff_radius, calcnfromq, na - implicit none integer, intent(in) :: im, levs, lm, lmk, lmp, n_var_lndp, & @@ -685,10 +683,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo endif if_thompson if (imp_physics == imp_physics_nssl) then - ! write(6,*) 'rrtm_pre: set qx_mp for NSSL',ntlnc,ntinc,ntsnc,ntrnc IF ( .not. effr_in ) THEN do k=1,LMK -! IF ( me == mpiroot ) write(6,*) 'k,rho: ',k,rho(1,k) do i=1,IM qvs = qgrs(i,k,ntqv) qv_mp (i,k) = qvs/(1.-qvs) @@ -705,11 +701,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo ENDIF -! write(6,*) 'rrtmg_pre: max qctrac,qc,qcphy,nctrac,ccw,ccwphy: ',maxval(qc_mp),maxval(qc), & -! maxval(qc_phys),maxval(nc_mp),maxval(ccw),maxval(ccw_phys) -! write(6,*) 'rrtmg_pre: max ni,ns,nr = ',maxval(ni_mp),maxval(ns_mp),maxval(nr_mp) - ! IF ( maxval(ni_mp) > 1.0 ) write(6,*) 'NI max = ',maxval(ni_mp) - ! IF ( maxval(qi_mp) > 0.01e-3 ) write(6,*) 'QI max = ',maxval(qi_mp) endif endif do n=1,ncndl @@ -816,98 +807,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo else -#if 0 - ! calculate radii here, but something is not right with incoming number concentrations - ! IF ( .true. .and. first_time_step ) THEN - IF ( ( maxval(qc_mp) > 1.e-11 .and. maxval(nc_mp) < 1.e-5 ) .or. & - ( maxval(qr_mp) > 1.e-11 .and. maxval(nr_mp) < 1.e-5 ) .or. & - ( maxval(qi_mp) > 1.e-11 .and. maxval(ni_mp) < 1.e-5 ) .or. & - ( maxval(qs_mp) > 1.e-11 .and. maxval(ns_mp) < 1.e-5 ) .or. kdt < 3 ) THEN -! ( maxval(qs_mp) > 1.e-11 .and. maxval(ns_mp) < 1.e-5 ) .or. .true. ) THEN - - allocate( an(im,1,lm,na) ) - an(:,:,:,:) = 0.0 - IF ( .true. .or. kdt <= 3 ) THEN - IF ( me == mpiroot ) THEN -! write(6,*) 'before calcn: max ccw = ',maxval(nc_mp),sum(nc_mp) - nc_mp2 = nc_mp - max1 = maxval(nc_mp) - sum1 = sum(nc_mp) - ENDIF -! IF ( maxval(nc_mp) < 1.e-20 ) THEN - call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & - & qcw=qc_mp,qci=qi_mp, qsw=qs_mp,qrw=qr_mp, & - & ccw=nc_mp,cci=ni_mp, csw=ns_mp,crw=nr_mp, & - & qv=qv_mp, invertccn_flag=nssl_invertccn ) -! ENDIF - IF ( .false. .and. me == mpiroot ) THEN - max2 = maxval(nc_mp) - sum2 = sum(nc_mp) - write(6,*) 'after calcn: max ccw = ',maxval(nc_mp),sum(nc_mp) - IF ( Abs(max1-max2) < 1.0 .and. Abs(sum2-sum1) > 1.0 ) THEN - DO k=1,lm - DO i=1,im - IF ( qc_mp(i,k) > 1.e-6 .and. (nc_mp2(i,k) /= nc_mp(i,k) ) ) THEN - write(6,*) 'i,k,qc,nc1,nc2 = ',i,k,qc_mp(i,k),nc_mp2(i,k),nc_mp(i,k) - ENDIF - ENDDO - ENDDO - ENDIF - ENDIF - ELSE -! call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & -! & qcw=qc_mp, & !qci=qi_mp, & ! qsw=qs_mp,qrw=qr_mp, & -! & ccw=nc_mp, & !cci=ni_mp, & ! csw=ns_mp,crw=nr_mp, & -! & cccn=cccn_mp,qv=qv_mp ) - call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & - & qci=qi_mp, qsw=qs_mp,qrw=qr_mp, & - & cci=ni_mp, csw=ns_mp,crw=nr_mp, & - & qv=qv_mp, invertccn_flag=nssl_invertccn ) - ENDIF - ! write(0,*) 'rrtmg_pre2: ni,ns,nr maxval: ',maxval(ni_mp),maxval(ns_mp),maxval(nr_mp),kdt - - deallocate( an ) - ENDIF - re_cloud = 0 - re_ice = 0 - re_snow = 0 - re_rain = 0 - call calc_eff_radius & - & (nx=im,ny=1,nz=lm,na=1,jyslab=1 & - & ,nor=0,norz=0 & - & ,t1=re_cloud,t2=re_ice,t3=re_snow,t4=re_rain & - & ,qcw=qc_mp,qci=qi_mp,qsw=qs_mp,qrw=qr_mp & - & ,ccw=nc_mp,cci=ni_mp,csw=ns_mp,crw=nr_mp & - & ,dn=rho ) - - do k=1,lm - k1 = k + kd - do i=1,im - IF ( .false. ) THEN - effrl(i,k1) = MAX(2.51E-6, MIN( re_cloud(i,k), 50.E-6))*1.e6 - effri(i,k1) = MAX(10.01E-6, MIN( re_ice(i,k), 125.E-6))*1.e6 - effrs(i,k1) = MAX(25.E-6, MIN( re_snow(i,k), 999.E-6))*1.e6 - ! effri(i,k1) = effri_inout(i,k)! re_ice (i,k) - ! effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) - ELSE - effrl(i,k1) = effrl_inout(i,k)! re_cloud (i,k) - effri(i,k1) = effri_inout(i,k)! re_ice (i,k) - effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) - ENDIF - effrr(i,k1) = MAX(25.E-6, MIN( re_rain(i,k), 2999.E-6))*1.e6 - enddo - enddo - - ! Update global arrays - do k=1,lm - k1 = k + kd - do i=1,im - effrl_inout(i,k) = effrl(i,k1) - effri_inout(i,k) = effri(i,k1) - effrs_inout(i,k) = effrs(i,k1) - enddo - enddo -#endif + ! not used yet -- effr_in should always be true for now endif elseif (imp_physics == imp_physics_thompson) then ! Thompson MP diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 40d07f1a9..65a05c3fa 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1,7 +1,7 @@ [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,module_mp_nssl_2mom.F90 + 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,physcons.F90,physparam.f,radcons.f90,radiation_aerosols.f dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90,radiation_cloud_overlap.F90 diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 65fecae7e..c96ab4861 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1,7 +1,8 @@ -!WRF:MODEL_LAYER:PHYSICS +! !> \file module_mp_nssl_2mom.F90 +!! This file contains the NSSL cloud microphysics scheme by Edward Mansell (NOAA/NSSL) -! prepocessed on "Oct 6 2021" at "17:14:05" +! prepocessed on "Oct 18 2021" at "17:18:18" @@ -169,11 +170,11 @@ MODULE module_mp_nssl_2mom - use physcons, only: con_pi, con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps IMPLICIT NONE public nssl_2mom_driver public nssl_2mom_init + public nssl_2mom_init_const public calc_eff_radius public calcnfromq private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis @@ -830,13 +831,13 @@ MODULE module_mp_nssl_2mom ! new values for cs and ds real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient - real, parameter :: cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv - real, parameter :: pi = con_pi + real :: cp608 = 0.608 ! constant used in conversion of T to Tv + real :: gr = 9.8 + + real, parameter :: pi = 3.141592653589793 real, parameter :: piinv = 1./pi real, parameter :: pid4 = pi/4.0 - real, parameter :: gr = con_g - ! ! max and min mean volumes ! @@ -899,19 +900,23 @@ MODULE module_mp_nssl_2mom real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation real, parameter :: cawbolton = 17.67 - real, parameter :: tfr = con_t0c, tfrh = 233.15 + real, parameter :: tfrh = 233.15 + real :: tfr = 273.15 - real, parameter :: cp = con_cp, rd = con_rd, rw = con_rv - REAL, PRIVATE, parameter :: cpl = con_cliq ! 4190.0 - REAL, PRIVATE, parameter :: cpigb = con_csol ! 2106.0 - real, parameter :: cpi = 1./cp - real, parameter :: cap = rd/cp, poo = 1.0e+05 + real :: cp = 1004.0, rd = 287.04 + real :: rw = 461.5 ! gas const. for water vapor + REAL, PRIVATE :: cpl = 4190.0 + REAL, PRIVATE :: cpigb = 2106.0 + real :: cpi + real :: cap + real :: tfrcbw + real :: tfrcbi + real :: rovcp + real, parameter :: poo = 1.0e+05 real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity - real, parameter :: tfrcbw = tfr - cbw - real, parameter :: tfrcbi = tfr - cbi ! GHB: Needed for eqtset=2 in cm1 ! REAL, PRIVATE :: cv = cp - rd @@ -1094,44 +1099,6 @@ MODULE module_mp_nssl_2mom ! ##################################################################### ! ##################################################################### - SUBROUTINE wrf_debug( level, message ) - implicit none - integer :: level - character(*) :: message - - IF ( level < 0 ) THEN - write(0,*) message - ENDIF - - END SUBROUTINE wrf_debug - -! -! ##################################################################### -! - SUBROUTINE wrf_message( message ) - implicit none - character(*) :: message - - write(0,*) message - - END SUBROUTINE wrf_message - -! -! ##################################################################### -! - SUBROUTINE wrf_error_fatal( message ) - ! USE COMMASMPI_MODULE, only: commasmpi_abort - implicit none - character(*) :: message - - write(0,*) message - ! call commasmpi_abort() - - END SUBROUTINE wrf_error_fatal - -! -! ##################################################################### -! REAL FUNCTION fqvs(t) implicit none @@ -1148,6 +1115,35 @@ END FUNCTION fqis +! ##################################################################### +! ##################################################################### + + + SUBROUTINE nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + implicit none + real, intent(in) :: con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps + + cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv + gr = con_g + tfr = con_t0c + cp = con_cp + rd = con_rd + rw = con_rv + cpl = con_cliq ! 4190.0 + cpigb = con_csol ! 2106.0 + cpi = 1./cp + cap = rd/cp + tfrcbw = tfr - cbw + tfrcbi = tfr - cbi + rovcp = rd/cp + + + + RETURN + END SUBROUTINE nssl_2mom_init_const ! ##################################################################### ! ##################################################################### @@ -1581,7 +1577,9 @@ SUBROUTINE nssl_2mom_init( & ! ltmp = lhlw ENDIF ELSE - CALL wrf_error_fatal( 'nssl_2mom_init: Invalid value of ipctmp' ) + errmsg = 'nssl_2mom_init: Invalid value of ipctmp' + errflg = 1 + RETURN ENDIF @@ -2299,19 +2297,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw - IF ( switchccn .and. lccna > 1 .and. .not. invertccn) THEN - ! hack to switch from ccn to ccna from a restart - - DO jy = jts,jte - DO kz = kts,kte - DO ix = its,ite - cn(ix,kz,jy) = Max( 0.0, old_qccn - cn(ix,kz,jy) ) - ENDDO - ENDDO - ENDDO - - switchccn = .false. - ENDIF ! ENDIF ! itimestep == 1 @@ -2365,6 +2350,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) ancuten(its:ite,1,kts:kte,:) = 0.0 + thproclocal(:,:) = 0.0 DO jy = jts,jye @@ -2739,7 +2725,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,t0,t9 & & ,an,dn1,t77 & & ,pn,wn & - & ,thproclocal,nproc,dx1,dy1,dz2d & & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) @@ -2823,7 +2808,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw DO kz = kts,kte DO ix = its,ite re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6)) - re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 125.E-6)) + re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 200.E-6)) re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation) IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) @@ -2925,6 +2910,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO ! jy + @@ -2957,7 +2943,6 @@ REAL FUNCTION GAMMA_SP(xx) IF ( xx <= 0.0 ) THEN write(0,*) 'Argument to gamma must be > 0!! xx = ',xx - STOP ENDIF x = xx @@ -3021,7 +3006,6 @@ real function GAMXINF(A1,X1) XAM=-X+A*DLOG(X) IF (XAM.GT.700.0.OR.A.GT.170.0) THEN WRITE(*,*)'a and/or x too large' - STOP ENDIF IF (X.EQ.0.0) THEN GIN=0.0 @@ -3082,7 +3066,6 @@ double precision function GAMXINFDP(A1,X1) XAM=-X+A*DLOG(X) IF (XAM.GT.700.0.OR.A.GT.170.0) THEN WRITE(*,*)'a and/or x too large' - STOP ENDIF IF (X.EQ.0.0) THEN GIN=0.0 @@ -3502,7 +3485,6 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) del = tmp - dgam*i IF ( i+1 > ngm0 ) THEN write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp - STOP ENDIF g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami ! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua) @@ -3790,8 +3772,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO n = 1,ndfall - IF ( ( il /= lc .and. il /= li ) .and. do_accurate_sedimentation .and. n .ge. 2 .and. & - ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN + IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN ! ! zero the precip flux arrays (2d) ! @@ -3799,7 +3780,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! xvt(:,:,:,il) = 0.0 dummy = 0.d0 - IF ( il == lh .or. il == lr ) xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin + xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & & xvt, rhovtzx, & @@ -6403,9 +6384,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! DO il = lc,lhab ! IF ( il .ne. lr ) THEN DO mgs = 1,ngscnt - IF ( ildo == 0 .or. ildo == lc ) THEN - vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) - ENDIF + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) IF ( li .gt. 1 ) THEN ! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) ! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) @@ -8128,8 +8107,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & write(0,*) 'dtmpr = ',dtmpr write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN - write(0,*) 'dbz out of bounds! STOP!' -! STOP + write(0,*) 'dbz out of bounds!' ENDIF ENDIF @@ -8178,7 +8156,6 @@ SUBROUTINE NUCOND & & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & - & ,thproc,numproc, dx1,dy1,gz & & ,axtra,io_flag & & ,ssfilt,t00,t77,flag_qndrop & & ) @@ -8233,9 +8210,6 @@ SUBROUTINE NUCOND & ! local - integer, intent(in) :: numproc - real, intent(inout) :: thproc(nz,numproc) - real, intent(in) :: dx1,dy1, gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) logical :: io_flag @@ -8397,7 +8371,6 @@ SUBROUTINE NUCOND & real :: cvm,cpm,rmm - real, parameter :: rovcp = rd/cp real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure integer :: kstag @@ -8854,11 +8827,6 @@ SUBROUTINE NUCOND & IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) - qx(mgs,lc)*rho0(mgs)*dv/dtp ! evaporation rate - ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp ENDIF @@ -8915,11 +8883,6 @@ SUBROUTINE NUCOND & cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) - felv(mgs)*QEVAP/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) - QEVAP*rho0(mgs)*dv/dtp ! evaporation rate - ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp ENDIF @@ -9190,11 +9153,6 @@ SUBROUTINE NUCOND & IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) ENDIF - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + e1*(DCLOUD + dqr)*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + (DCLOUD + dqr)*rho0(mgs)*dv/dtp ! condensation rate - ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp @@ -9262,11 +9220,6 @@ SUBROUTINE NUCOND & thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate - ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp ENDIF @@ -9524,11 +9477,6 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate - ENDIF ENDIF ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air @@ -9635,11 +9583,6 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate - ENDIF ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) ENDIF @@ -9698,11 +9641,6 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate - ENDIF ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ENDIF @@ -9750,11 +9688,6 @@ SUBROUTINE NUCOND & IF ( qvex .gt. 0.0 ) THEN thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*qvex/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + qvex*rho0(mgs)*dv/dtp ! condensation rate - ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp ENDIF @@ -10775,7 +10708,6 @@ subroutine nssl_2mom_gs & real cvm,cpm,rmm - real, parameter :: rovcp = rd/cp real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure ! real fcci(ngs), fcip(ngs) @@ -19731,104 +19663,6 @@ subroutine nssl_2mom_gs & ! ! Load the save arrays ! - IF ( numproc > 1 ) THEN - DO mgs = 1,ngscnt - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - IF ( ipconc > 2 ) THEN - thproc(kzbeg-1+kgs(mgs),1) = thproc(kzbeg-1+kgs(mgs),1) + crfrzf(mgs)*dtp*dv - ELSE - thproc(kzbeg-1+kgs(mgs),1) = thproc(kzbeg-1+kgs(mgs),1) + qrfrzf(mgs)*rho0(mgs)*dtp*dv - ENDIF - thproc(kzbeg-1+kgs(mgs),2) = thproc(kzbeg-1+kgs(mgs),2) + il5(mgs)*ciacrf(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),3) = thproc(kzbeg-1+kgs(mgs),3) + chcnsh(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),4) = thproc(kzbeg-1+kgs(mgs),4) + chcnih(mgs)*dtp*dv - IF ( qhacw(mgs)+qhacr(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN - thproc(kzbeg-1+kgs(mgs),5) = thproc(kzbeg-1+kgs(mgs),5) + (qhacw(mgs)+qhacr(mgs)+qhshr(mgs))*rho0(mgs)*dtp*dv - ENDIF - thproc(kzbeg-1+kgs(mgs),6) = thproc(kzbeg-1+kgs(mgs),6) + qracw(mgs)*rho0(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),7) = thproc(kzbeg-1+kgs(mgs),7) + qrcnw(mgs)*rho0(mgs)*dtp*dv - IF ( qhacw(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN - thproc(kzbeg-1+kgs(mgs),8) = thproc(kzbeg-1+kgs(mgs),8) + (vhacw(mgs)+vhacr(mgs)+vhshdr(mgs))*dtp*dv -! thproc(kzbeg-1+kgs(mgs),8) = thproc(kzbeg-1+kgs(mgs),8) + qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh)*dtp*dv - ENDIF - thproc(kzbeg-1+kgs(mgs),9) = thproc(kzbeg-1+kgs(mgs),9) + ptem(mgs)*dtp*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),10) = thproc(kzbeg-1+kgs(mgs),10) + & - & ( chmul1(mgs) + chlmul1(mgs) )*dtp*dv - IF ( lf > 1 ) THEN - ELSE - thproc(kzbeg-1+kgs(mgs),11) = thproc(kzbeg-1+kgs(mgs),11) + & - & ( csplinter(mgs) + csplinter2(mgs) )*dtp*dv - ENDIF - thproc(kzbeg-1+kgs(mgs),12) = thproc(kzbeg-1+kgs(mgs),12) + qrfrzf(mgs)*rho0(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),13) = thproc(kzbeg-1+kgs(mgs),13) + il5(mgs)*qiacrf(mgs)*rho0(mgs)*dtp*dv ! mass of rain freezing by ice crystal capture - thproc(kzbeg-1+kgs(mgs),14) = thproc(kzbeg-1+kgs(mgs),14) + crcnw(mgs)*dtp*dv ! rain drop prod. by autoconv. - thproc(kzbeg-1+kgs(mgs),15) = thproc(kzbeg-1+kgs(mgs),15) + (pcrwi(mgs)-crcnw(mgs))*dtp*dv ! rain drop prod by melting/shedding (i.e., everything but autoconv.) -! thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate - thproc(kzbeg-1+kgs(mgs),19) = thproc(kzbeg-1+kgs(mgs),19) + pmlt(mgs)*rho0(mgs)*dv ! melting rate - thproc(kzbeg-1+kgs(mgs),20) = thproc(kzbeg-1+kgs(mgs),20) + pdep(mgs)*rho0(mgs)*dv ! deposition rate - thproc(kzbeg-1+kgs(mgs),21) = thproc(kzbeg-1+kgs(mgs),21) + (psub(mgs)-pdep(mgs))*rho0(mgs)*dv ! sublimation rate - thproc(kzbeg-1+kgs(mgs),22) = thproc(kzbeg-1+kgs(mgs),22) + (pfrz(mgs)-pmlt(mgs))*rho0(mgs)*dv ! freezing rate - -! thproc(kzbeg-1+kgs(mgs),20) = thproc(kzbeg-1+kgs(mgs),20) + (1./pi0(mgs))*felfcp(mgs)*pvap(mgs)*rho0(mgs)*dv ! deposition rate -! thproc(kzbeg-1+kgs(mgs),21) = thproc(kzbeg-1+kgs(mgs),21) + (1./pi0(mgs))*felscp(mgs)*psub(mgs)*rho0(mgs)*dv ! sublimation rate -! thproc(kzbeg-1+kgs(mgs),22) = thproc(kzbeg-1+kgs(mgs),22) + (1./pi0(mgs))*felfcp(mgs)*pfrz(mgs)*rho0(mgs)*dv ! (pfrz(mgs)-pmlt(mgs))*rho0(mgs)*dv ! freezing rate - - thproc(kzbeg-1+kgs(mgs),23) = thproc(kzbeg-1+kgs(mgs),23) + crfrzs(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),24) = thproc(kzbeg-1+kgs(mgs),24) + il5(mgs)*ciacrs(mgs)*dtp*dv - - thproc(kzbeg-1+kgs(mgs),25) = thproc(kzbeg-1+kgs(mgs),25) + qhmlr(mgs)*rho0(mgs)*dv ! melting rate - thproc(kzbeg-1+kgs(mgs),26) = thproc(kzbeg-1+kgs(mgs),26) + qhlmlr(mgs)*rho0(mgs)*dv ! melting rate - - IF ( qhlacw(mgs)+qhlacr(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN - thproc(kzbeg-1+kgs(mgs),27) = thproc(kzbeg-1+kgs(mgs),27) + (qhlacw(mgs)+qhlacr(mgs)+qhlshr(mgs))*rho0(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),28) = thproc(kzbeg-1+kgs(mgs),28) + (qhlacw(mgs))*rho0(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),29) = thproc(kzbeg-1+kgs(mgs),29) + (qhlacr(mgs))*rho0(mgs)*dtp*dv - ENDIF - - IF ( temg(mgs) < tfr ) THEN - thproc(kzbeg-1+kgs(mgs),30) = thproc(kzbeg-1+kgs(mgs),30) + (qhacw(mgs))*rho0(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),31) = thproc(kzbeg-1+kgs(mgs),31) + (qhacr(mgs))*rho0(mgs)*dtp*dv - ENDIF - - thproc(kzbeg-1+kgs(mgs),32) = thproc(kzbeg-1+kgs(mgs),32) + qhlcnh(mgs)*rho0(mgs)*dtp*dv ! graupel mass conversion to hail - - IF ( ihrn > 0 ) THEN - thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + ciihr(mgs)*dtp*dv ! contact freezing of droplets - ELSE - IF ( qwctfz(mgs)*dtp >= qxmin(li) ) THEN - thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + cwctfz(mgs)*dtp*dv ! contact freezing of droplets - ENDIF - ENDIF - thproc(kzbeg-1+kgs(mgs),34) = thproc(kzbeg-1+kgs(mgs),34) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate - IF ( qiint(mgs)*dtp >= qxmin(li) ) THEN - thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + ciint(mgs)*dtp*dv ! primary ice initiation - ENDIF - IF ( lf > 1 ) THEN - ELSE - thproc(kzbeg-1+kgs(mgs),38) = thproc(kzbeg-1+kgs(mgs),38) + (vhacw(mgs)+vhacr(mgs)+vhshdr(mgs))*dtp*dv - ENDIF - IF ( lhl > 1 ) THEN - thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + chlcnhhl(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),37) = thproc(kzbeg-1+kgs(mgs),37) + (vhlacw(mgs)+vhlacr(mgs)+vhlshdr(mgs))*dtp*dv - ELSE - IF ( lf > 1 ) THEN - ELSE - thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + (pchwi(mgs))*dtp*dv - thproc(kzbeg-1+kgs(mgs),39) = thproc(kzbeg-1+kgs(mgs),39) + (pchwd(mgs))*dtp*dv - thproc(kzbeg-1+kgs(mgs),37) = thproc(kzbeg-1+kgs(mgs),37) + (chmlr(mgs))*dtp*dv - ENDIF - ENDIF -! thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate - - -! ptem(mgs) = & -! & (1./pi0(mgs))* & -! & (felfcp(mgs)*pfrz(mgs) & -! & +felscp(mgs)*psub(mgs) & -! & +felvcp(mgs)*pvap(mgs)) - - ENDDO - ENDIF ! Sample code for using the axtra array to load microphysical rates or quantities for output diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 754b99ca2..e607e132d 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -25,6 +25,8 @@ module mp_nssl !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & mpirank, mpiroot, & + con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps, & imp_physics, imp_physics_nssl, convert_dry_rho, & nssl_cccn, nssl_alphah, nssl_alphahl, & nssl_ccn_on, nssl_hail_on, nssl_invertccn, first_time_step, & @@ -32,8 +34,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl ) - use module_mp_nssl_2mom, only: nssl_2mom_init, calcnfromq, na - use physcons, only: con_rd + use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const, calcnfromq, na implicit none @@ -43,6 +44,8 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent( out) :: errflg integer, intent(in) :: threads logical, intent(in) :: restart + real(kind_phys), intent(in) :: con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps integer, intent(in) :: mpirank integer, intent(in) :: mpiroot @@ -134,6 +137,11 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & return end if + ! set physical constants + call nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + ! Set internal dimensions ims = 1 ime = ncol diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 1ec3d03e4..4d3f3b00f 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -71,6 +71,78 @@ type = integer intent = in optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[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 + optional = F +[con_cliq] + standard_name = specific_heat_of_liquid_water_at_constant_pressure + long_name = specific heat of liquid water at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_csol] + standard_name = specific_heat_of_ice_at_constant_pressure + long_name = specific heat of ice at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme From 53658e5cf52616659e02177e8e4f9133ff1ca868 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Tue, 19 Oct 2021 12:51:10 -0500 Subject: [PATCH 025/217] Added dependencies to RUC physics --- physics/radiation_surface.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/radiation_surface.meta b/physics/radiation_surface.meta index beab83ce9..668a2bd21 100644 --- a/physics/radiation_surface.meta +++ b/physics/radiation_surface.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = module_radiation_surface type = module - dependencies = + dependencies = namelist_soilveg_ruc.F90,set_soilveg_ruc.F90 ######################################################################## [ccpp-arg-table] From da10201f6ba0bf9b9bf3dc85467c49526b3f758d Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Tue, 9 Nov 2021 21:49:55 -0600 Subject: [PATCH 026/217] Cleaned up unused code and variables. --- physics/GFS_rrtmg_pre.F90 | 36 +---- physics/GFS_rrtmg_pre.meta | 16 -- physics/GFS_suite_interstitial.F90 | 10 +- physics/GFS_suite_interstitial.meta | 16 -- physics/module_mp_nssl_2mom.F90 | 30 ++-- physics/mp_nssl.F90 | 198 +++-------------------- physics/mp_nssl.meta | 237 +++++----------------------- 7 files changed, 88 insertions(+), 455 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 35ea44203..7396c676d 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -19,7 +19,7 @@ end subroutine GFS_rrtmg_pre_init subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & - ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, first_time_step, & + ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & imp_physics,imp_physics_nssl, nssl_ccn_on, nssl_invertccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & @@ -36,7 +36,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & gasvmr_o2, gasvmr_co, gasvmr_cfc11, gasvmr_cfc12, gasvmr_cfc22, & gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, faersw1, faersw2, faersw3, faerlw1, faerlw2, & - faerlw3, alpha, errmsg, errflg,mpiroot) + faerlw3, alpha, errmsg, errflg) use machine, only: kind_phys @@ -103,7 +103,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & logical, intent(in) :: lsswr, lslwr, ltaerosol, lgfdlmprad, & uni_cld, effr_in, do_mynnedmf, & - lmfshal, lmfdeep2, pert_clds,first_time_step + lmfshal, lmfdeep2, pert_clds logical, intent(in) :: nssl_ccn_on, nssl_invertccn real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp @@ -176,7 +176,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - integer, intent(in) :: mpiroot ! Local variables integer :: ncndl @@ -197,10 +196,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(im,lm+LTP) :: & re_cloud, re_ice, re_snow, qv_mp, qc_mp, & qi_mp, qs_mp, nc_mp, ni_mp, nwfa - ! for NSSL MP - real(kind=kind_phys), dimension(im,lm+LTP) :: & - re_rain, qr_mp, ns_mp, nr_mp, nh_mp, vh_mp, cccn_mp,cccna_mp, nc_mp2 - real, allocatable :: an(:,:,:,:) ! temporary scalar array ! for F-A MP real(kind=kind_phys), dimension(im,lm+LTP) :: qc_save, qi_save, qs_save @@ -223,7 +218,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & its, ite, jts, jte, kts, kte real(kind=kind_phys) :: qvs - real (kind=kind_phys) :: sum1,sum2,max1,max2 ! !===> ... begin here ! @@ -682,26 +676,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo endif if_thompson - if (imp_physics == imp_physics_nssl) then - IF ( .not. effr_in ) THEN - do k=1,LMK - do i=1,IM - qvs = qgrs(i,k,ntqv) - qv_mp (i,k) = qvs/(1.-qvs) - rho (i,k) = con_eps*plyr(i,k)*100./(con_rd*tlyr(i,k)*(qv_mp(i,k)+con_eps)) - qc_mp (i,k) = tracer1(i,k,ntcw)/(1.-qvs) - qi_mp (i,k) = tracer1(i,k,ntiw)/(1.-qvs) - qs_mp (i,k) = tracer1(i,k,ntsw)/(1.-qvs) - qr_mp (i,k) = tracer1(i,k,ntrw)/(1.-qvs) - nc_mp (i,k) = tracer1(i,k,ntlnc)/(1.-qvs) - ni_mp (i,k) = tracer1(i,k,ntinc)/(1.-qvs) - ns_mp (i,k) = tracer1(i,k,ntsnc)/(1.-qvs) - nr_mp (i,k) = tracer1(i,k,ntrnc)/(1.-qvs) - IF ( nssl_ccn_on ) cccn_mp(i,k) = tracer1(i,k,ntccn)/(1.-qvs) - enddo - enddo - ENDIF - endif endif do n=1,ncndl do k=1,LMK @@ -1097,7 +1071,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif ! MYNN PBL or GF - elseif(imp_physics == imp_physics_thompson ) then ! Thompson MP + elseif(imp_physics == imp_physics_thompson) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv !-- MYNN PBL or convective GF @@ -1196,4 +1170,6 @@ end subroutine GFS_rrtmg_pre_run subroutine GFS_rrtmg_pre_finalize () end subroutine GFS_rrtmg_pre_finalize +!! @} + end module GFS_rrtmg_pre diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 65a05c3fa..d9d7ba541 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -297,14 +297,6 @@ type = integer intent = in optional = F -[first_time_step] - standard_name = flag_for_first_timestep - long_name = flag for first time step for time integration loop (cold/warmstart) - units = flag - dimensions = () - type = logical - intent = in - optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -1250,11 +1242,3 @@ type = integer intent = out optional = F -[mpiroot] - standard_name = mpi_root - long_name = master MPI-rank - units = index - dimensions = () - type = integer - intent = in - optional = F diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index cdc1a54ac..728325c8e 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -512,7 +512,7 @@ end subroutine GFS_suite_interstitial_3_finalize !> \section arg_table_GFS_suite_interstitial_3_run Argument Table !! \htmlinclude GFS_suite_interstitial_3_run.html !! - subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & + subroutine GFS_suite_interstitial_3_run (otsptflag, & im, levs, nn, cscnv, & satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & @@ -531,8 +531,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & implicit none ! interface variables - logical, intent(in) :: otsptflag(1:ntracp1)! on/off switch for tracer transport - integer, intent(in) :: ntracp1 + logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport (size ntrac) integer, intent(in ) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, ntsw,& ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & @@ -717,7 +716,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr imp_physics_nssl, nssl_invertccn, nssl_ccn_on, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & - qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, ntracp1, errmsg, errflg) + qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, errmsg, errflg) use machine, only: kind_phys use module_mp_nssl_2mom, only: qccn @@ -728,8 +727,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ! interface variables - logical, intent(in) :: otsptflag(1:ntracp1)! on/off switch for tracer transport by updraft and - integer, intent(in) :: ntracp1 + logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport by updraft and integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 6c2767f66..ae516be47 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1175,14 +1175,6 @@ type = logical intent = in optional = F -[ntracp1] - standard_name = number_of_tracers_plus_one - long_name = number of tracers plus one - units = count - dimensions = () - type = integer - intent = in - optional = F [im] standard_name = horizontal_loop_extent long_name = horizontal loop extent @@ -2102,14 +2094,6 @@ type = logical intent = in optional = F -[ntracp1] - standard_name = number_of_tracers_plus_one - long_name = number of tracers plus one - units = count - dimensions = () - type = integer - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index c96ab4861..7131739c0 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1,8 +1,4 @@ ! !> \file module_mp_nssl_2mom.F90 -!! This file contains the NSSL cloud microphysics scheme by Edward Mansell (NOAA/NSSL) - - -! prepocessed on "Oct 18 2021" at "17:18:18" @@ -11,6 +7,9 @@ +!--------------------------------------------------------------------- +! code snapshot: "Oct 29 2021" at "19:44:39" +!--------------------------------------------------------------------- !--------------------------------------------------------------------- ! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: ! moist_adv_opt = 4, @@ -2811,7 +2810,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 200.E-6)) re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation) - IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) + IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 200.E-6)) ENDDO ENDDO @@ -3777,7 +3776,6 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! zero the precip flux arrays (2d) ! -! xvt(:,:,:,il) = 0.0 dummy = 0.d0 xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin @@ -6384,7 +6382,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! DO il = lc,lhab ! IF ( il .ne. lr ) THEN DO mgs = 1,ngscnt - vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + IF ( ildo == 0 .or. ildo == lc ) THEN + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + ENDIF IF ( li .gt. 1 ) THEN ! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) ! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) @@ -10867,6 +10867,7 @@ subroutine nssl_2mom_gs & real chlsbv(ngs), chldpv(ngs) real chlmlr(ngs), chlmlrr(ngs) + real chlfmlr(ngs) ! real chlmlrsave(ngs),chlsave(ngs),qhlsave(ngs) real chlshr(ngs), chlshrr(ngs) @@ -12017,6 +12018,13 @@ subroutine nssl_2mom_gs & ENDIF +! +! Set liquid water fraction +! + fhw(:) = 0.0 + fsw(:) = 0.0 + fhlw(:) = 0.0 + @@ -15547,6 +15555,7 @@ subroutine nssl_2mom_gs & chmlr(:) = 0.0 chmlrr(:) = 0.0 chlmlr(:) = 0.0 + chlfmlr(:) = 0.0 ! chlmlrsave(:) = 0.0 ! qhlmlrsave(:) = 0.0 ! chlsave(:) = 0.0 @@ -18147,10 +18156,8 @@ subroutine nssl_2mom_gs & ! qwfrzp(mgs) = frac*qwfrzp(mgs) ! qwctfzp(mgs) = frac*qwctfzp(mgs) qwfrzc(mgs) = frac*qwfrzc(mgs) - qwfrzis(mgs) = frac*qwfrzis(mgs) qwfrz(mgs) = frac*qwfrz(mgs) qwctfzc(mgs) = frac*qwctfzc(mgs) - qwctfzis(mgs) = frac*qwctfzis(mgs) qwctfz(mgs) = frac*qwctfz(mgs) qracw(mgs) = frac*qracw(mgs) qsacw(mgs) = frac*qsacw(mgs) @@ -18818,10 +18825,9 @@ subroutine nssl_2mom_gs & write(iunit,*) ' Conc:' write(iunit,*) pccii(mgs),pccid(mgs) write(iunit,*) il5(mgs),cicint(mgs) - write(iunit,*) cwacii(mgs),cwfrzc(mgs),cwctfzc(mgs) + write(iunit,*) cwfrzc(mgs),cwctfzc(mgs) write(iunit,*) cicichr(mgs) write(iunit,*) chmul1(mgs) - write(iunit,*) cfmul1(mgs) write(iunit,*) chlmul1(mgs) write(iunit,*) csmul(mgs) ! @@ -18835,7 +18841,6 @@ subroutine nssl_2mom_gs & write(iunit,*) -il5(mgs)*qiacw(mgs) write(iunit,*) -il5(mgs)*qwfrzc(mgs) write(iunit,*) -il5(mgs)*qwctfzc(mgs) - write(iunit,*) -il5(mgs)*qwctfzis(mgs) ! write(iunit,*) -il5(mgs)*qwfrzp(mgs) ! write(iunit,*) -il5(mgs)*qwctfzp(mgs) write(iunit,*) -il5(mgs)*qiihr(mgs) @@ -18884,7 +18889,6 @@ subroutine nssl_2mom_gs & write(iunit,*) -qhlacr(mgs) write(iunit,*) qrcev(mgs) write(iunit,*) 'pqrwd = ', pqrwd(mgs) - write(iunit,*) 'fhw, fhlw = ',fhw(mgs),fhlw(mgs) write(iunit,*) 'qrzfac = ', qrzfac(mgs) ! diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index e607e132d..cf1a4b8fa 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -27,14 +27,12 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & mpirank, mpiroot, & con_g, con_rd, con_cp, con_rv, & con_t0c, con_cliq, con_csol, con_eps, & - imp_physics, imp_physics_nssl, convert_dry_rho, & + imp_physics, imp_physics_nssl, & nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_ccn_on, nssl_hail_on, nssl_invertccn, first_time_step, & - spechum, qc, qr, qi, qs, qh, qhl, & - cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl ) + nssl_ccn_on, nssl_hail_on, nssl_invertccn ) - use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const, calcnfromq, na + use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const implicit none @@ -53,57 +51,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent(in) :: imp_physics_nssl real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn - logical, intent(in) :: first_time_step - ! Hydrometeors - logical, intent(in ) :: convert_dry_rho - real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) - 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) :: qhl(:,:) ! (1:ncol,1:nlev) ! hail - real(kind_phys), intent(inout) :: cccn(:,:) ! (1:ncol,1:nlev) - real(kind_phys), intent(inout) :: cccna(:,:) ! (1:ncol,1:nlev) ! currently not used - 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) :: chl(:,:) ! (1:ncol,1:nlev) ! hail number - real(kind_phys), intent(inout) :: vh(1:ncol,1:nlev) ! graupel volume - real(kind_phys), intent(inout) :: vhl(:,:) ! (1:ncol,1:nlev) ! hail volume - - ! State variables and timestep information - real(kind_phys), intent(inout) :: tgrs(1:ncol,1:nlev) - real(kind_phys), intent(in ) :: prsl(1:ncol,1:nlev) - real(kind_phys), intent(in ) :: prslk(1:ncol,1:nlev) - - ! Air density - real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 - ! Hydrometeors -! real(kind_phys) :: qv_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) -! real(kind_phys) :: qc_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) -! real(kind_phys) :: qr_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) -! real(kind_phys) :: qi_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) -! real(kind_phys) :: qs_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) -! real(kind_phys) :: qh_mp(1:ncol,1:nlev) !< kg kg-1 (graupel dry mixing ratio) - real(kind_phys) :: qhl_mp(1:ncol,1:nlev) !< kg kg-1 (hail dry mixing ratio) -! real(kind_phys) :: nc_mp(1:ncol,1:nlev) !< droplet num. conc. -! real(kind_phys) :: nr_mp(1:ncol,1:nlev) !< rain num. conc. -! real(kind_phys) :: ni_mp(1:ncol,1:nlev) !< ice crystal num. conc. -! real(kind_phys) :: ns_mp(1:ncol,1:nlev) !< snow num. conc. -! real(kind_phys) :: nh_mp(1:ncol,1:nlev) !< graupel num. conc. -! real(kind_phys) :: nhl_mp(1:ncol,1:nlev) !< hail num. conc. - real(kind_phys) :: vh_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) - real(kind_phys) :: cccn_mp(1:ncol,1:nlev) - real(kind_phys) :: cccna_mp(1:ncol,1:nlev) - ! create temporaries for hail in case it does not exist - real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) - real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) - - real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array ! Local variables: dimensions used in nssl_init integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k real :: nssl_params(20) @@ -116,16 +64,14 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ! write(0,*) 'nssl_init: nlev,ncol,rank = ',nlev,ncol,mpirank - if (is_initialized .and. .not. first_time_step ) return + if ( is_initialized ) return IF ( .not. is_initialized ) THEN ! only do this on first call if (mpirank==mpiroot) then write(0,*) ' ----------------------------------------------------------------------------------------------------------------' write(0,*) ' --- CCPP NSSL MP scheme init ---' -! write(0,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development --- WARNING ---' write(0,*) ' ----------------------------------------------------------------------------------------------------------------' write(6,*) ' ----------------------------------------------------------------------------------------------------------------' -! write(6,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development --- WARNING ---' write(6,*) ' --- CCPP NSSL MP scheme init ---' write(6,*) ' ----------------------------------------------------------------------------------------------------------------' end if @@ -137,7 +83,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & return end if - ! set physical constants + ! set some physical constants in NSSL microphysics to be consistent with parent model call nssl_2mom_init_const( & con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) @@ -179,111 +125,15 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ihailv = -1 ENDIF - IF ( imp_physics == imp_physics_nssl ) THEN ! ( .not. nssl_ccn_flag ) ! write(0,*) 'call nssl_2mom_init' CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & ihvol=ihailv,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) -! write(0,*) 'done nssl_2mom_init' -! ELSE -! write(0,*) 'call nssl_2mom_init ccn: imp_physics, imp_physics_nssl2mccn = ',imp_physics, imp_physics_nssl2mccn -! CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) -! write(0,*) 'done nssl_2mom_init ccn' - ENDIF - - is_initialized = .true. - - ENDIF ! .not. is_initialized - -#if 0 -! IF ( is_initialized .and. ((.not. first_time_step) .or. restart ) ) THEN -! return -! ENDIF - - ! Following code only runs on first time step -- hopefully for all slabs - !> - Density of air in kg m-3 - rho = prsl/(con_rd*tgrs) - allocate( an(nx,1,nz,na) ) - an(:,:,:,:) = 0.0 - -! spechum, qc, qr, qi, qs, qh, qhl, & -! cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl ) - - ! use local arrays for variables that might not exist - ! implied loops - IF ( nssl_hail_on ) THEN - qhl_mp = qhl - vhl_mp = vhl - chl_mp = chl - ELSE - qhl_mp = 0 - vhl_mp = 0 - chl_mp = 0 - ENDIF - IF ( nssl_ccn_on ) THEN - cccn_mp = nssl_qccn ! cccn - cccna_mp = 0 - ELSE - cccn_mp = nssl_qccn - cccna_mp = 0 - ENDIF -! qr_mp = qr -! qs_mp = qs -! write(0,*) 'mp_nssl_init1: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh),maxval(rho) -! write(0,*) 'mp_nssl_init: call calcnfromq',restart,is_initialized,first_time_step - call calcnfromq(nx=nx,ny=1,nz=nz,an=an,na=na,nor=0,norz=0,dn=rho, & - & qcw=qc,qci=qi,qsw=qs,qrw=qr,qhw=qh,qhl=qhl_mp, & - & ccw=ccw,cci=cci,csw=csw,crw=crw,chw=chw,chl=chl_mp, & - & cccn=cccn_mp,cccna=cccna_mp, vhw=vh,vhl=vhl_mp ) - -! qr = qr_mp -! qs = qs_mp - - ! write(0,*) 'mp_nssl_init2: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh),maxval(rho) - ! write(0,*) 'mp_nssl_init2: ni,ns,nh maxval: ',maxval(cci),maxval(csw),maxval(chw) -! DO k = 1,nz -! DO i = 1,nx -! IF ( qi(i,k) > 1.e-4 ) write(6,*) 'qi,ni = ',qi(i,k),cci(i,k) -! IF ( qs(i,k) > 1.e-3 ) write(6,*) 'qs,ns = ',qs(i,k),csw(i,k) -! IF ( qh(i,k) > 1.e-3 ) write(6,*) 'qh,nh = ',qh(i,k),chw(i,k) -! ENDDO -! ENDDO - - IF ( nssl_hail_on ) THEN - qhl = qhl_mp - vhl = vhl_mp - chl = chl_mp - ENDIF - IF ( nssl_ccn_on ) THEN - IF ( nssl_invertccn ) THEN - !cccn = cccna_mp - DO k = 1,nlev - DO i = 1,ncol - cccn(i,k) = nssl_qccn - cccn_mp(i,k) - ENDDO - ENDDO - ELSE - cccn = cccn_mp - ENDIF - ENDIF - -! qs = 0 -! qi = 0 -! qr = 0 - -! call calc_eff_radius & -! & (nx=im,ny=1,nz=lm,na=1,jyslab=1 & -! & ,nor=0,norz=0 & -! & ,t1=re_cloud,t2=re_ice,t3=re_snow,t4=re_rain & -! & ,qcw=qc_mp,qci=qi_mp,qsw=qs_mp,qrw=qr_mp & -! & ,ccw=nc_mp,cci=ni_mp,csw=ns_mp,crw=nr_mp & -! & ,dn=rho ) + is_initialized = .true. - - deallocate( an ) -#endif + ENDIF ! .not. is_initialized return @@ -303,6 +153,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, & re_cloud, re_ice, re_snow, re_rain, & + nleffr, nieffr, nseffr, nreffr, & imp_physics, convert_dry_rho, & imp_physics_nssl, nssl_ccn_on, & nssl_hail_on, nssl_invertccn, ntccn, ntccna, & @@ -352,10 +203,11 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & real(kind_phys), intent(inout) :: refl_10cm(1:ncol,1:nlev) logical, intent(in ) :: do_radar_ref, first_time_step ! Cloud effective radii - real(kind_phys), optional, intent(inout) :: re_cloud(:,:) ! (1:ncol,1:nlev) - real(kind_phys), optional, intent(inout) :: re_ice(:,:) ! (1:ncol,1:nlev) - real(kind_phys), optional, intent(inout) :: re_snow(:,:) ! (1:ncol,1:nlev) - real(kind_phys), optional, intent(inout) :: re_rain(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_cloud(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_ice(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_snow(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_rain(:,:) ! (1:ncol,1:nlev) + integer, intent(in) :: nleffr, nieffr, nseffr, nreffr integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn @@ -447,7 +299,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ! write(0,*) 'nssl_run: nlev,ncol,rank = ',nlev,ncol,mpirank - IF ( ndebug > 1 ) write(0,*) 'In physics nssl_run' + IF ( ndebug >= 1 ) write(0,*) 'In physics nssl_run' ! Check initialization state @@ -559,8 +411,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & xdelta_graupel_mp = 0 xdelta_ice_mp = 0 xdelta_snow_mp = 0 - - IF ( ndebug >= 1 ) THEN + IF ( ndebug > 1 ) THEN write(*,*) 'Max q before micro' write(*,*) 'qc = ',1000.*maxval(qc_mp) write(*,*) 'qr = ',1000.*maxval(qr_mp) @@ -580,13 +431,15 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & do_radar_ref_mp = 0 end if - if (present(re_cloud) .and. present(re_ice) .and. present(re_snow)) then + do_effective_radii = .false. + IF ( nleffr > 0 .and. nieffr > 0 .and. nseffr > 0 .and. nreffr > 0 ) THEN + ! if (present(re_cloud) .and. present(re_ice) .and. present(re_snow)) then do_effective_radii = .true. has_reqc = 1 has_reqi = 1 has_reqs = 1 - IF ( present( re_rain ) ) has_reqr = 1 - else if (.not.present(re_cloud) .and. .not.present(re_ice) .and. .not.present(re_snow)) then + has_reqr = 1 + else if (nleffr < 1 .and. nieffr < 1 .and. nseffr < 1 .and. nreffr < 1 ) then do_effective_radii = .false. has_reqc = 0 has_reqi = 0 @@ -594,8 +447,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & has_reqr = 0 else write(errmsg,fmt='(*(a))') 'Logic error in mp_nssl_run:', & - ' all or none of the following optional', & - ' arguments are required: re_cloud, re_ice, re_snow' + ' hydrometeor radius calculation logic problem' errflg = 1 return end if @@ -626,7 +478,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & kte = nlev - IF ( ndebug > 1 ) write(0,*) 'call nssl_2mom_driver' + IF ( ndebug >= 1 ) write(0,*) 'call nssl_2mom_driver' IF ( dtp > 1.5*dtpmax ) THEN ntmul = Nint( dtp/dtpmax ) @@ -650,7 +502,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & itimestep = 2 ENDIF - IF ( .false. ) THEN + IF ( .false. ) THEN ! disable for now, as logic in the NSSL driver does this, but may switch back to here ! incoming droplet field may have some inconsistent number concentrations (e.g., from PBL) ! so check for that, otherwise mass may be zapped into vapor allocate( an(ncol,1,nlev,na) ) @@ -854,7 +706,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & if (errflg/=0) return - IF ( ndebug >= 1 ) THEN + IF ( ndebug > 1 ) THEN write(*,*) 'Max q after micro' write(*,*) 'qc = ',1000.*maxval(qc_mp) write(*,*) 'qr = ',1000.*maxval(qr_mp) @@ -946,7 +798,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & re_rain = re_rain_mp*1.0E6_kind_phys end if - IF ( ndebug > 1 ) write(0,*) 'mp_nssl: end' + IF ( ndebug >= 1 ) write(0,*) 'mp_nssl: end' end subroutine mp_nssl_run !>@} diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 4d3f3b00f..2e5b3e017 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -151,14 +151,6 @@ type = integer intent = in optional = F -[convert_dry_rho] - standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air - long_name = flag for converting hydrometeors from moist to dry air - units = flag - dimensions = () - type = logical - intent = in - optional = F [imp_physics_nssl] standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme @@ -218,195 +210,6 @@ type = logical intent = in optional = F -[first_time_step] - standard_name = flag_for_first_timestep - long_name = flag for first time step for time integration loop (cold/warmstart) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[spechum] - standard_name = specific_humidity - long_name = water vapor specific humidity - units = kg kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[qhl] - standard_name = hail_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of hail - units = kg kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[cccn] - standard_name = cloud_condensation_nuclei_number_concentration - long_name = number concentration of cloud condensation nuclei - units = kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[cccna] - standard_name = activated_cloud_condensation_nuclei_number_concentration - long_name = number concentration of activated cloud condensation nuclei - units = kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[chl] - standard_name = mass_number_concentration_of_hail_in_air - long_name = hail number concentration - units = kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[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 - optional = F -[vhl] - standard_name = hail_volume - long_name = hail particle volume - units = m3 kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[prslk] - standard_name = dimensionless_exner_function - long_name = dimensionless Exner function at model layer centers - units = none - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in - optional = F - ######################################################################## [ccpp-arg-table] name = mp_nssl_run @@ -747,7 +550,7 @@ type = real kind = kind_phys intent = inout - optional = T + optional = F [re_ice] standard_name = effective_radius_of_stratiform_cloud_ice_particle long_name = eff. radius of cloud ice water particle in micrometer @@ -756,7 +559,7 @@ type = real kind = kind_phys intent = inout - optional = T + optional = F [re_snow] standard_name = effective_radius_of_stratiform_cloud_snow_particle long_name = effective radius of cloud snow particle in micrometer @@ -765,7 +568,7 @@ type = real kind = kind_phys intent = inout - optional = T + optional = F [re_rain] standard_name = effective_radius_of_stratiform_cloud_rain_particle long_name = effective radius of cloud rain particle in micrometers @@ -774,7 +577,39 @@ type = real kind = kind_phys intent = inout - optional = T + optional = F +[nleffr] + standard_name = index_of_cloud_liquid_water_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of cloud liquid water effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in + optional = F +[nieffr] + standard_name = index_of_cloud_ice_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of ice effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in + optional = F +[nreffr] + standard_name = index_of_rain_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of rain effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in + optional = F +[nseffr] + standard_name = index_of_snow_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of snow effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme From 805c62c1a89b867b676a50555dc43f323fe1bf56 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 7 Dec 2021 10:39:05 -0700 Subject: [PATCH 027/217] add single precision code changes from michalakes fork, jm-nrl-32bitfp-24cc09e branch --- physics/calpreciptype.f90 | 77 +++++++++-------- physics/funcphys.f90 | 138 ++++++++++++++++++++++++++----- physics/machine.F | 14 ++-- physics/module_bl_mynn.F90 | 14 ++-- physics/radlw_main.F90 | 10 ++- physics/radsw_main.F90 | 9 +- physics/sfc_diag_post.F90 | 9 +- physics/surface_perturbation.F90 | 2 +- 8 files changed, 197 insertions(+), 76 deletions(-) diff --git a/physics/calpreciptype.f90 b/physics/calpreciptype.f90 index dcc8ed49b..d3fbb253b 100644 --- a/physics/calpreciptype.f90 +++ b/physics/calpreciptype.f90 @@ -26,17 +26,18 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & ! -------------------------------------------------------------------- use funcphys, only : fpvs,ftdp,fpkap,ftlcl,stma,fthe use physcons + use machine , only : kind_phys !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! - real, parameter :: pthresh = 0.0, oneog = 1.0/con_g + real(kind=kind_phys), parameter :: pthresh = 0.0, oneog = 1.0/con_g integer,parameter :: nalg = 5 ! ! declare variables. ! integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1 - real,intent(in) :: xlat(im),xlon(im) - real,intent(in) :: randomno(ix,nrcm) + real(kind=kind_phys),intent(in) :: xlat(im),xlon(im) + real(kind=kind_phys),intent(in) :: randomno(ix,nrcm) real(kind=kind_phys),dimension(im), intent(in) :: prec,tskin real(kind=kind_phys),dimension(ix,lm), intent(in) :: gt0,gq0,prsl real(kind=kind_phys),dimension(ix,lp1),intent(in) :: prsi,phii @@ -220,8 +221,9 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & !! This subroutine computes precipitation type using a decision tree approach that uses !! variables such as integrated wet bulb temperatue below freezing and lowest layer !! temperature (Baldwin et al. 1994 \cite baldwin_et_al_1994) - subroutine calwxt(lm,lp1,t,q,pmid,pint, & - d608,rog,epsq,zint,iwx,twet) + subroutine calwxt(lm,lp1,t,q,pmid,pint, & + d608,rog,epsq,zint,iwx,twet) + use machine , only : kind_phys ! ! file: calwxt.f ! written: 11 november 1993, michael baldwin @@ -247,10 +249,10 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! t,q,pmid,htm,lmh,zint ! integer,intent(in) :: lm,lp1 - real,dimension(lm),intent(in) :: t,q,pmid,twet - real,dimension(lp1),intent(in) :: zint,pint + real(kind=kind_phys),dimension(lm),intent(in) :: t,q,pmid,twet + real(kind=kind_phys),dimension(lp1),intent(in) :: zint,pint integer,intent(out) :: iwx - real,intent(in) :: d608,rog,epsq + real(kind=kind_phys),intent(in) :: d608,rog,epsq ! output: @@ -264,10 +266,10 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! ! internal: ! -! real, allocatable :: twet(:) - real, parameter :: d00=0.0 +! real(kind=kind_phys), allocatable :: twet(:) + real(kind=kind_phys), parameter :: d00=0.0 integer karr,licee - real tcold,twarm + real(kind=kind_phys) tcold,twarm ! subroutines called: ! wetbulb @@ -282,7 +284,7 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! integer l,lice,iwrml,ifrzl - real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4, & + real(kind=kind_phys) psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4, & surfw,surfc,dzkl,area1,pintk1,pintk2,pm150,pkl,tkl,qkl ! allocate ( twet(lm) ) @@ -486,27 +488,28 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! use params_mod ! use ctlblk_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use machine , only : kind_phys implicit none ! - real,parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & + real(kind=kind_phys),parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & & emelt=0.045,rlim=0.04,slim=0.85 - real,parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now + real(kind=kind_phys),parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now ! integer*4 i, k1, lll, k2, toodry ! - real xxx ,mye, icefrac + real(kind=kind_phys) xxx ,mye, icefrac integer, intent(in) :: lm,lp1 - real,dimension(lm), intent(in) :: t,q,pmid,rh,td - real,dimension(lp1),intent(in) :: pint + real(kind=kind_phys),dimension(lm), intent(in) :: t,q,pmid,rh,td + real(kind=kind_phys),dimension(lp1),intent(in) :: pint integer, intent(out) :: ptyp ! - real,dimension(lm) :: tq,pq,rhq,twq + real(kind=kind_phys),dimension(lm) :: tq,pq,rhq,twq ! integer j,l,lev,ii - real rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & + real(kind=kind_phys) rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & rhavg,dtavg,dpk,ptw,pbot -! real b,qtmp,rate,qc - real,external :: xmytw +! real(kind=kind_phys) b,qtmp,rate,qc +! real(kind=kind_phys),external :: xmytw (now inside the module) ! ! initialize. icefrac = -9999. @@ -521,7 +524,7 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! causing problems later in this subroutine ! qtmp=max(h1m12,q(l)) ! rhqtmp(lev)=qtmp/qc - rhq(lev) = rh(l) + rhq(lev) = rh(l) pq(lev) = pmid(l) * 0.01 tq(lev) = t(l) enddo @@ -753,10 +756,11 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) !-------------------------------------------------------------------------- function xmytw(t,td,p) ! + use machine , only : kind_phys implicit none ! integer*4 cflag, l - real f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & + real(kind=kind_phys) f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & & de, xmytw data f, c0, c1, c2 /0.0006355, 26.66082, 0.0091379024, 6106.3960/ ! @@ -877,19 +881,20 @@ function xmytw(t,td,p) !! \cite bourgouin_2000. !of aes (canada) 1992 subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) + use machine , only : kind_phys implicit none ! ! input: integer,intent(in) :: lm,lp1 - real,intent(in) :: g,rn(2) - real,intent(in), dimension(lm) :: t, q, pmid - real,intent(in), dimension(lp1) :: pint, zint + real(kind=kind_phys),intent(in) :: g,rn(2) + real(kind=kind_phys),intent(in), dimension(lm) :: t, q, pmid + real(kind=kind_phys),intent(in), dimension(lp1) :: pint, zint ! ! output: integer, intent(out) :: ptype ! integer ifrzl,iwrml,l,lhiwrm - real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 + real(kind=kind_phys) pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 ! ! initialize weather type array to zero (ie, off). ! we do this since we want ptype to represent the @@ -1076,6 +1081,7 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! use params_mod ! use ctlblk_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use machine , only : kind_phys implicit none ! ! list of variables needed @@ -1087,9 +1093,9 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! t,q,pmid,htm,lmh,zint integer,intent(in) :: lm,lp1 - real,dimension(lm),intent(in) :: t,q,pmid,twet - real,dimension(lp1),intent(in) :: pint,zint - real,intent(in) :: d608,rog,epsq + real(kind=kind_phys),dimension(lm),intent(in) :: t,q,pmid,twet + real(kind=kind_phys),dimension(lp1),intent(in) :: pint,zint + real(kind=kind_phys),intent(in) :: d608,rog,epsq ! output: ! iwx - instantaneous weather type. ! acts like a 4 bit binary @@ -1101,12 +1107,12 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & integer, intent(out) :: iwx ! internal: ! - real, parameter :: d00=0.0 + real(kind=kind_phys), parameter :: d00=0.0 integer karr,licee - real tcold,twarm + real(kind=kind_phys) tcold,twarm ! integer l,lmhk,lice,iwrml,ifrzl - real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4,area1, & + real(kind=kind_phys) psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4,area1, & surfw,surfc,dzkl,pintk1,pintk2,pm150,qkl,tkl,pkl,area0,areap0 ! subroutines called: @@ -1316,14 +1322,15 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & ! algorithms and sums them up to give a dominant type ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use machine , only : kind_phys implicit none ! ! input: integer,intent(in) :: nalg - real,intent(out) :: doms,domr,domzr,domip + real(kind=kind_phys),intent(out) :: doms,domr,domzr,domip integer,dimension(nalg),intent(in) :: rain,snow,sleet,freezr integer l - real totsn,totip,totr,totzr + real(kind=kind_phys) totsn,totip,totr,totzr !-------------------------------------------------------------------------- ! print* , 'into dominant' domr = 0. diff --git a/physics/funcphys.f90 b/physics/funcphys.f90 index 8cb4b1b15..3e81a0d5a 100644 --- a/physics/funcphys.f90 +++ b/physics/funcphys.f90 @@ -260,7 +260,7 @@ module funcphys ! Language: Fortran 90 ! !$$$ - use machine,only:kind_phys + use machine,only:kind_phys,r8=>kind_dbl_prec,r4=>kind_sngl_prec use physcons implicit none private @@ -308,6 +308,13 @@ module funcphys public grkap,frkap,frkapq,frkapx public gtlcl,ftlcl,ftlclq,ftlclo,ftlclx public gfuncphys + + interface fpvsl + module procedure fpvsl_r4, fpvsl_r8 + end interface fpvsl + interface fpvsi + module procedure fpvsi_r4, fpvsi_r8 + end interface fpvsi contains !------------------------------------------------------------------------------- !> This subroutine computes saturation vapor pressure table as a function of @@ -364,7 +371,8 @@ subroutine gpvsl !! in gpvsl(). See documentation for fpvslx() for details. Input values !! outside table range are reset to table extrema. !>\author N phillips - elemental function fpvsl(t) + + elemental function fpvsl_r4(t) !$$$ Subprogram Documentation Block ! ! Subprogram: fpvsl Compute saturation vapor pressure over liquid @@ -396,16 +404,62 @@ elemental function fpvsl(t) ! !$$$ implicit none - real(krealfp) fpvsl - real(krealfp),intent(in):: t + real(r4) fpvsl_r4 + real(r4),intent(in):: t integer jx - real(krealfp) xj + real(r4) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) - jx=min(xj,nxpvsl-1._krealfp) - fpvsl=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) + xj=min(max(c1xpvsl+c2xpvsl*t,1._r4),real(nxpvsl,r4)) + jx=min(xj,nxpvsl-1._r4) + fpvsl_r4=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function + end function fpvsl_r4 + + elemental function fpvsl_r8(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsl Compute saturation vapor pressure over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A linear interpolation is done between values in a lookup table +! computed in gpvsl. See documentation for fpvslx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 6 decimal places. +! On the Cray, fpvsl is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: pvsl=fpvsl(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsl Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(r8) fpvsl_r8 + real(r8),intent(in):: t + integer jx + real(r8) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsl+c2xpvsl*t,1._r8),real(nxpvsl,r8)) + jx=min(xj,nxpvsl-1._r8) + fpvsl_r8=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function fpvsl_r8 + + + !------------------------------------------------------------------------------- !> This function computes saturation vapor pressure from the temperature. !! A quadratic interpolation is done between values in a lookup table @@ -576,7 +630,8 @@ subroutine gpvsi !! computed in gpvsi(). See documentation for fpvsix() for details. !! Input values outside table range are reset to table extrema. !>\author N Phillips - elemental function fpvsi(t) + + elemental function fpvsi_r4(t) !$$$ Subprogram Documentation Block ! ! Subprogram: fpvsi Compute saturation vapor pressure over ice @@ -609,16 +664,61 @@ elemental function fpvsi(t) ! !$$$ implicit none - real(krealfp) fpvsi - real(krealfp),intent(in):: t + real(r4) fpvsi_r4 + real(r4),intent(in):: t integer jx - real(krealfp) xj + real(r4) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) - jx=min(xj,nxpvsi-1._krealfp) - fpvsi=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) + xj=min(max(c1xpvsi+c2xpvsi*t,1._r4),real(nxpvsi,r4)) + jx=min(xj,nxpvsi-1._r4) + fpvsi_r4=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function + end function fpvsi_r4 + + elemental function fpvsi_r8(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsi Compute saturation vapor pressure over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A linear interpolation is done between values in a lookup table +! computed in gpvsi. See documentation for fpvsix for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 6 decimal places. +! On the Cray, fpvsi is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvsi=fpvsi(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsi Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(r8) fpvsi_r8 + real(r8),intent(in):: t + integer jx + real(r8) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsi+c2xpvsi*t,1._r8),real(nxpvsi,r8)) + jx=min(xj,nxpvsi-1._r8) + fpvsi_r8=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function fpvsi_r8 + !------------------------------------------------------------------------------- !> This function computes saturation vapor pressure from the temperature. !! A quadratic interpolation is done between values in a lookup table @@ -2375,7 +2475,7 @@ elemental subroutine stmaq(the,pk,tma,qma) !>\param[in] pk real, pressure over 1e5 Pa to the kappa power !>\param[out] tma real, parcel temperature in Kelvin !>\param[out] qma real, parcel specific humidity in kg/kg - elemental subroutine stmax(the,pk,tma,qma) + subroutine stmax(the,pk,tma,qma) !$$$ Subprogram Documentation Block ! ! Subprogram: stmax Compute moist adiabat temperature @@ -2443,7 +2543,7 @@ elemental subroutine stmax(the,pk,tma,qma) !>\param[in] pk real, pressure over 1e5 Pa to the kappa power !>\param[out] tma real, parcel temperature in Kelvin !>\param[out] qma real, parcel specific humidity in kg/kg - elemental subroutine stmaxg(tg,the,pk,tma,qma) + subroutine stmaxg(tg,the,pk,tma,qma) !$$$ Subprogram Documentation Block ! ! Subprogram: stmaxg Compute moist adiabat temperature diff --git a/physics/machine.F b/physics/machine.F index 896b665da..2ee7fb865 100644 --- a/physics/machine.F +++ b/physics/machine.F @@ -9,11 +9,12 @@ module machine #ifndef SINGLE_PREC integer, parameter :: kind_io4 = 4, kind_io8 = 8 , kind_ior = 8 & &, kind_evod = 8, kind_dbl_prec = 8 & -#ifdef __PGI + &, kind_sngl_prec = 4 +# ifdef __PGI &, kind_qdt_prec = 8 & -#else +# else &, kind_qdt_prec = 16 & -#endif +# endif &, kind_rad = 8 & &, kind_phys = 8 ,kind_taum=8 & &, kind_grid = 8 & @@ -24,11 +25,12 @@ module machine #else integer, parameter :: kind_io4 = 4, kind_io8 = 8 , kind_ior = 8 & &, kind_evod = 4, kind_dbl_prec = 8 & -#ifdef __PGI + &, kind_sngl_prec = 4 +# ifdef __PGI &, kind_qdt_prec = 8 & -#else +# else &, kind_qdt_prec = 16 & -#endif +# endif &, kind_rad = 4 & &, kind_phys = 4 ,kind_taum=4 & &, kind_grid = 4 & diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index d691de909..ff9574a27 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -142,6 +142,7 @@ MODULE module_bl_mynn & XLF => con_hfus, & & EP_1 => con_fvirt, & & EP_2 => con_eps + use machine, only : kind_phys IMPLICIT NONE @@ -1470,8 +1471,11 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos lb1(iz) = min(dlu(iz),dld(iz)) !minimum !JOE-fight floating point errors +#ifdef SINGLE_PREC + !JM: keep up the fight, JOE dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) +#endif lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average @@ -2692,7 +2696,7 @@ SUBROUTINE mym_condensation (kts,kte, & !CLOUD WATER AND ICE IF (q1k < 0.) THEN !unstaurated - ql_water = sgm(k)*EXP(1.2*q1k-1) + ql_water = sgm(k)*EXP(1.2*q1k-1.) ql_ice = sgm(k)*EXP(1.2*q1k-1.) !Reduce ice mixing ratios in the upper troposphere ! low_weight = MIN(MAX(p(k)-40000.0, 0.0),40000.0)/40000.0 @@ -6723,15 +6727,15 @@ FUNCTION qsat_blend(t, P, waterice) IF ((t .GE. 273.16) .OR. (wrt .EQ. 'w')) THEN ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - qsat_blend = 0.622*ESL/(P-ESL) + qsat_blend = 0.622*ESL/max((P-ESL),1.0E-7_kind_phys) ELSE IF (t .LE. 253.) THEN ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - qsat_blend = 0.622*ESI/(P-ESI) + qsat_blend = 0.622*ESI/max((P-ESI),1.0E-7_kind_phys) ELSE ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - RSLF = 0.622*ESL/(P-ESL) - RSIF = 0.622*ESI/(P-ESI) + RSLF = 0.622*ESL/max((P-ESL),1.0E-7_kind_phys) + RSIF = 0.622*ESI/max((P-ESI),1.0E-7_kind_phys) chi = (273.16-t)/20.16 qsat_blend = (1.-chi)*RSLF + chi*RSIF END IF diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 89609c283..b6e41b094 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -286,7 +286,8 @@ module rrtmg_lw & random_stat !mz use machine, only : kind_phys, & - & im => kind_io4, rb => kind_phys + & im => kind_io4, rb => kind_phys, & + & kind_dbl_prec use module_radlw_parameters ! @@ -2071,9 +2072,10 @@ subroutine mcica_subcol & logical, dimension(ngptlw,nlay), intent(out) :: lcloudy ! --- locals: - real (kind=kind_phys) :: cdfunc(ngptlw,nlay), rand1d(ngptlw), & - & rand2d(nlay*ngptlw), tem1, fac_lcf(nlay), & + real (kind=kind_phys) :: cdfunc(ngptlw,nlay), & + & tem1, fac_lcf(nlay), & & cdfun2(ngptlw,nlay) + real (kind=kind_dbl_prec) rand2d(nlay*ngptlw), rand1d(ngptlw) type (random_stat) :: stat ! for thread safe random generator @@ -8968,4 +8970,4 @@ end subroutine cldprmc !........................................!$ end module rrtmg_lw !$ -!========================================!$ \ No newline at end of file +!========================================!$ diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index 0f5a8b110..32097d868 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -310,7 +310,7 @@ module rrtmg_sw use physcons, only : con_g, con_cp, con_avgd, con_amd, & & con_amw, con_amo3 use machine, only : rb => kind_phys, im => kind_io4, & - & kind_phys + & kind_phys, kind_dbl_prec use module_radsw_parameters use mersenne_twister, only : random_setseed, random_number, & @@ -1733,6 +1733,10 @@ subroutine rswinit & tfn = float(i) / float(NTBMX-i) tau = bpade * tfn exp_tbl(i) = exp( -tau ) +#ifdef SINGLE_PREC + ! from WRF version, prevents zero at single prec + if (exp_tbl(i) .le. expeps) exp_tbl(i) = expeps +#endif enddo return @@ -2213,8 +2217,9 @@ subroutine mcica_subcol & ! --- locals: real (kind=kind_phys) :: cdfunc(nlay,ngptsw), tem1, & - & rand2d(nlay*ngptsw), rand1d(ngptsw), fac_lcf(nlay), & + & fac_lcf(nlay), & & cdfun2(nlay,ngptsw) + real (kind=kind_dbl_prec) :: rand2d(nlay*ngptsw), rand1d(ngptsw) type (random_stat) :: stat ! for thread safe random generator diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90 index 6f14fe93d..26f4f1ba8 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/sfc_diag_post.F90 @@ -19,7 +19,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg) - use machine, only: kind_phys + use machine, only: kind_phys, kind_dbl_prec implicit none @@ -35,7 +35,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con integer, intent(out) :: errflg integer :: i - real(kind=kind_phys) :: tem + real(kind=kind_dbl_prec) :: tem ! made dbl prec always, JM 20211104 ! Initialize CCPP error handling variables errmsg = '' @@ -57,8 +57,9 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con v10mmax(i) = v10m(i) endif ! Compute dew point, first using vapor pressure - tem = max(pgr(i) * q2m(i) / ( con_eps - con_epsm1 *q2m(i)), 1.e-8) - dpt2m(i) = 243.5 / ( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 + tem = max(pgr(i) * q2m(i) / ( con_eps - con_epsm1 *q2m(i)), 1.d-8) + dpt2m(i) = 243.5_kind_dbl_prec / & + ( ( 17.67_kind_dbl_prec / log(tem/611.2_kind_dbl_prec) ) - 1.) + 273.14 enddo endif diff --git a/physics/surface_perturbation.F90 b/physics/surface_perturbation.F90 index e0429a5fc..7ddbe5279 100644 --- a/physics/surface_perturbation.F90 +++ b/physics/surface_perturbation.F90 @@ -48,7 +48,7 @@ subroutine cdfnor(z,cdfz) cdfz = 0.5 else x = 0.5*z*z - call cdfgam(x,0.5,del,iflag, cdfx) + call cdfgam(x,0.5_kind_phys,del,iflag, cdfx) if (iflag.ne.0) return if (z.gt.0.0) then cdfz = 0.5+0.5*cdfx From 4b42e194a696fcfbdf8de646f3f9ce55104582fd Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 31 Mar 2021 20:59:17 -0500 Subject: [PATCH 028/217] - Adds support for NSSL full 2-moment microphysics with droplets, rain, cloud ice, snow, graupel, and hail. Graupel and hail have predicted bulk density via the particle volume. Hail can be deactived. Simple CCN concentration can be predicted, either as the count of unactivated or activated nuclei. (Mansell et al. 2010, JAS) --- physics/GFS_MP_generic.F90 | 9 +- physics/GFS_MP_generic.meta | 16 + physics/GFS_PBL_generic.F90 | 116 +- physics/GFS_PBL_generic.meta | 128 + physics/GFS_rrtmg_pre.F90 | 34 +- physics/GFS_rrtmg_pre.meta | 16 + physics/GFS_rrtmgp_gfdlmp_pre.F90 | 2 +- physics/GFS_suite_interstitial.F90 | 92 +- physics/GFS_suite_interstitial.meta | 80 + physics/maximum_hourly_diagnostics.F90 | 25 +- physics/maximum_hourly_diagnostics.meta | 16 + physics/module_MYNNPBL_wrapper.F90 | 31 +- physics/module_MYNNPBL_wrapper.meta | 16 + physics/module_mp_nssl_2mom.F90 | 19729 ++++++++++++++++++++++ physics/mp_nsslg.F90 | 704 + physics/mp_nsslg.meta | 578 + 16 files changed, 21564 insertions(+), 28 deletions(-) create mode 100644 physics/module_mp_nssl_2mom.F90 create mode 100644 physics/mp_nsslg.F90 create mode 100644 physics/mp_nsslg.meta diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 6a8d3bfcb..588891b25 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -86,6 +86,7 @@ end subroutine GFS_MP_generic_post_init !> @{ subroutine GFS_MP_generic_post_run( & im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, con_g, rainmin, dtf, frain, rainc, & rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, 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, & @@ -101,6 +102,7 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires + integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm integer, intent(in) :: index_of_temperature,index_of_process_mp @@ -183,12 +185,12 @@ subroutine GFS_MP_generic_post_run( ice = ice0 snow = snow0 ! Do it right from the beginning for Thompson - else if (imp_physics == imp_physics_thompson) then + else if (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl2m & + .or. imp_physics == imp_physics_nssl2mccn) then tprcp = max (zero, rainc + frain * rain1) ! time-step convective and explicit precip graupel = frain*graupel0 ! time-step graupel ice = frain*ice0 ! time-step ice snow = frain*snow0 ! time-step snow - else if (imp_physics == imp_physics_fer_hires) then tprcp = max (zero, rain) ! time-step convective and explicit precip ice = frain*rain1*sr ! time-step ice @@ -264,7 +266,8 @@ subroutine GFS_MP_generic_post_run( !! and convective rainfall from the cumulus scheme if the surface temperature is below !! \f$0^oC\f$. - if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson) then + if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. & + imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn) then ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index d14c11baf..d43cf9297 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -213,6 +213,22 @@ dimensions = () type = integer intent = in +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [cal_pre] standard_name = flag_for_dominant_precipitation_type_partition long_name = flag controls precip type algorithm diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 5bbbefe52..e2446dbf8 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -82,8 +82,10 @@ end subroutine GFS_PBL_generic_pre_finalize subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, & ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & + ntccn, nthl, nthnc, ntgv, nthv, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, ltaerosol, & + imp_physics_nssl2m,imp_physics_nssl2mccn, ltaerosol, nssl_hail_on, & hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) @@ -97,10 +99,13 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, integer, intent(in) :: im, levs, nvdiff, ntrac integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv logical, intent(in) :: trans_aero, ldiag3d, qdiag3d, lssav integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend + integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn + logical, intent(in) :: cplchm, ltaerosol, nssl_hail_on real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs @@ -250,6 +255,59 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, enddo enddo rtg_ozone_index = 3 + elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + ! nssl + IF ( nssl_hail_on ) THEN + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,nthl) + vdftra(i,k,8) = qgrs(i,k,ntlnc) + vdftra(i,k,9) = qgrs(i,k,ntinc) + vdftra(i,k,10) = qgrs(i,k,ntrnc) + vdftra(i,k,11) = qgrs(i,k,ntsnc) + vdftra(i,k,12) = qgrs(i,k,ntgnc) + vdftra(i,k,13) = qgrs(i,k,nthnc) + vdftra(i,k,14) = qgrs(i,k,ntgv) + vdftra(i,k,15) = qgrs(i,k,nthv) + vdftra(i,k,16) = qgrs(i,k,ntoz) + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + vdftra(i,k,17) = qgrs(i,k,ntccn) + ENDIF + enddo + enddo + + ELSE + ! no hail + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntlnc) + vdftra(i,k,8) = qgrs(i,k,ntinc) + vdftra(i,k,9) = qgrs(i,k,ntrnc) + vdftra(i,k,10) = qgrs(i,k,ntsnc) + vdftra(i,k,11) = qgrs(i,k,ntgnc) + vdftra(i,k,12) = qgrs(i,k,ntgv) + vdftra(i,k,13) = qgrs(i,k,ntoz) + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + vdftra(i,k,14) = qgrs(i,k,ntccn) + ENDIF + enddo + enddo + + ENDIF + + endif ! if (trans_aero) then @@ -326,10 +384,10 @@ end subroutine GFS_PBL_generic_post_finalize !! subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev,nqrimef, & - trans_aero, ntchs, ntchm, & + trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, imp_physics_mg, & - imp_physics_fer_hires, & - ltaerosol, cplflx, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, & + imp_physics_fer_hires, imp_physics_nssl2m, imp_physics_nssl2mccn, & + ltaerosol, nssl_hail_on, cplflx, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf,& shinhong, do_ysu, dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, & dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & index_of_process_pbl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, & @@ -349,6 +407,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires + integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn, nssl_hail_on logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu @@ -546,6 +605,57 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntoz) = dvdftra(i,k,3) enddo enddo + elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + ! nssl + IF ( nssl_hail_on ) THEN + do k=1,levs + do i=1,im + dqdt(i,k,ntqv) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntrw) = dvdftra(i,k,4) + dqdt(i,k,ntsw) = dvdftra(i,k,5) + dqdt(i,k,ntgl) = dvdftra(i,k,6) + dqdt(i,k,nthl) = dvdftra(i,k,7) + dqdt(i,k,ntlnc) = dvdftra(i,k,8) + dqdt(i,k,ntinc) = dvdftra(i,k,9) + dqdt(i,k,ntrnc) = dvdftra(i,k,10) + dqdt(i,k,ntsnc) = dvdftra(i,k,11) + dqdt(i,k,ntgnc) = dvdftra(i,k,12) + dqdt(i,k,nthnc) = dvdftra(i,k,13) + dqdt(i,k,ntgv) = dvdftra(i,k,14) + dqdt(i,k,nthv) = dvdftra(i,k,15) + dqdt(i,k,ntoz) = dvdftra(i,k,16) + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + dqdt(i,k,ntccn) = dvdftra(i,k,17) + ENDIF + enddo + enddo + + ELSE + + do k=1,levs + do i=1,im + dqdt(i,k,ntqv) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntrw) = dvdftra(i,k,4) + dqdt(i,k,ntsw) = dvdftra(i,k,5) + dqdt(i,k,ntgl) = dvdftra(i,k,6) + dqdt(i,k,ntlnc) = dvdftra(i,k,7) + dqdt(i,k,ntinc) = dvdftra(i,k,8) + dqdt(i,k,ntrnc) = dvdftra(i,k,9) + dqdt(i,k,ntsnc) = dvdftra(i,k,10) + dqdt(i,k,ntgnc) = dvdftra(i,k,11) + dqdt(i,k,ntgv) = dvdftra(i,k,12) + dqdt(i,k,ntoz) = dvdftra(i,k,13) + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + dqdt(i,k,ntccn) = dvdftra(i,k,14) + ENDIF + enddo + enddo + + ENDIF endif endif ! nvdiff == ntrac diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 3dcf81043..842a95632 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -182,6 +182,46 @@ dimensions = () type = integer intent = in +[ntccn] + standard_name = index_for_cloud_condensation_nuclei_number_concentration + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthl] + standard_name = index_for_hail + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthnc] + standard_name = index_for_hail_number_concentration + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgv] + standard_name = index_for_graupel_volume + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthv] + standard_name = index_for_hail_volume + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -231,6 +271,22 @@ dimensions = () type = integer intent = in +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -238,6 +294,14 @@ dimensions = () type = logical intent = in +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [hybedmf] standard_name = flag_for_hybrid_edmf_pbl_scheme long_name = flag for hybrid edmf pbl scheme (moninedmf) @@ -553,6 +617,46 @@ dimensions = () type = integer intent = in +[ntccn] + standard_name = index_for_cloud_condensation_nuclei_number_concentration + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthl] + standard_name = index_for_hail + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthnc] + standard_name = index_for_hail_number_concentration + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgv] + standard_name = index_for_graupel_volume + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthv] + standard_name = index_for_hail_volume + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -602,6 +706,22 @@ dimensions = () type = integer intent = in +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -609,6 +729,14 @@ dimensions = () type = logical intent = in +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [cplflx] standard_name = flag_for_surface_flux_coupling long_name = flag controlling cplflx collection (default off) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index dbea66985..029c71637 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -20,6 +20,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & imp_physics_fer_hires, julian, yearlen, lndp_var_list, lsswr, lslwr, & @@ -93,6 +94,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, & imp_physics_mg, imp_physics_wsm6, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & imp_physics_fer_hires, & yearlen, icloud @@ -622,16 +624,21 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ccnd(i,k,4) = tracer1(i,k,ntsw) ! snow water enddo enddo - elseif (ncnd == 5) then ! GFDL MP, Thompson, MG3, FA + elseif ( ncnd == 5 .or. ncnd == 6) then ! GFDL MP, Thompson, MG3, NSSL do k=1,LMK do i=1,IM ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water ccnd(i,k,2) = tracer1(i,k,ntiw) ! ice water ccnd(i,k,3) = tracer1(i,k,ntrw) ! rain water + if (imp_physics == imp_physics_fer_hires ) then ccnd(i,k,4) = 0.0 else + IF ( ncnd == 5 ) THEN ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) ! snow + graupel + ELSEIF ( ncnd == 6 ) THEN + ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) + tracer1(i,k,nthl) ! snow + graupel + hail + ENDIF endif enddo enddo @@ -757,7 +764,24 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo endif - elseif (imp_physics == imp_physics_thompson) then ! Thompson MP + + elseif (imp_physics == imp_physics_nssl2m .or. & + imp_physics == imp_physics_nssl2mccn ) then ! NSSL MP + cldcov = 0.0 + if(effr_in) then + do k=1,lm + k1 = k + kd + do i=1,im + effrl(i,k1) = effrl_inout(i,k)! re_cloud (i,k) + effri(i,k1) = effri_inout(i,k)! re_ice (i,k) + effrr(i,k1) = 1000. ! rrain_def=1000. + effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) + enddo + enddo + endif + + elseif (imp_physics == imp_physics_thompson) then ! Thompson MP + ! ! Compute effective radii for QC, QI, QS with (GF, MYNN) or without (all others) sub-grid clouds ! @@ -1009,7 +1033,10 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & dzb, xlat_d, julian, yearlen, & clouds,cldsa,mtopa,mbota, de_lgth, alpha) ! --- outputs - elseif(imp_physics == imp_physics_thompson) then ! Thompson MP + elseif(imp_physics == imp_physics_thompson & + .or. imp_physics == imp_physics_nssl2m & + .or. imp_physics == imp_physics_nssl2mccn & + ) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv !-- MYNN PBL or convective GF @@ -1108,5 +1135,4 @@ end subroutine GFS_rrtmg_pre_run subroutine GFS_rrtmg_pre_finalize () end subroutine GFS_rrtmg_pre_finalize -!! @} end module GFS_rrtmg_pre diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 09ed62f7c..a018e0577 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -226,6 +226,22 @@ dimensions = () type = integer intent = in +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 index ccbfd1df8..ba1910133 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.F90 +++ b/physics/GFS_rrtmgp_gfdlmp_pre.F90 @@ -107,7 +107,7 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld errflg = 0 ! Test inputs - if (ncnd .ne. 5) then + if (ncnd .ne. 5 .and. ncnd .ne. 6 ) then errmsg = 'Incorrect number of cloud condensates provided' errflg = 1 call check_error_msg('GFS_rrtmgp_gfdlmp_pre_run',errmsg) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 6963e94c3..5aadec71b 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -512,13 +512,15 @@ end subroutine GFS_suite_interstitial_3_finalize !> \section arg_table_GFS_suite_interstitial_3_run Argument Table !! \htmlinclude GFS_suite_interstitial_3_run.html !! - subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & + subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & + im, levs, nn, cscnv, & satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & xlon, xlat, gt0, gq0, imp_physics, imp_physics_mg, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, dtidx, ntlnc, & imp_physics_wsm6, imp_physics_fer_hires, prsi, ntinc, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & work1, work2, kpbl, kinver, ras, me, save_lnc, save_inc, & ldiag3d, qdiag3d, index_of_process_conv_trans, & @@ -529,9 +531,12 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & implicit none ! interface variables + logical, intent(in) :: otsptflag(1:ntracp1)! on/off switch for tracer transport + integer, intent(in) :: ntracp1 integer, intent(in ) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, ntsw,& ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, me, index_of_process_conv_trans + imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & + imp_physics_nssl2m, imp_physics_nssl2mccn ,me, index_of_process_conv_trans integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras @@ -576,9 +581,10 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & if (cscnv .or. satmedmf .or. trans_trac .or. ras) then tracers = 2 do n=2,ntrac - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & +! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & +! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + IF ( otsptflag(n) ) THEN tracers = tracers + 1 do k=1,levs do i=1,im @@ -662,6 +668,13 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & else save_qi(:,:) = clw(:,:,1) endif + else if (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! ice + clw(i,k,2) = gq0(i,k,ntcw) ! water + enddo + enddo elseif (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_mg .or. imp_physics == imp_physics_fer_hires) then do k=1,levs do i=1,im @@ -699,22 +712,28 @@ end subroutine GFS_suite_interstitial_4_finalize !! subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl2m,imp_physics_nssl2mccn, nssl_invertccn, otsptflag, ntracp1, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) use machine, only: kind_phys + use module_mp_nssl_2mom, only: qccn use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber + implicit none ! interface variables + logical, intent(in) :: otsptflag(1:ntracp1)! on/off switch for tracer transport by updraft and + integer, intent(in) :: ntracp1 integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl2m, imp_physics_nssl2mccn logical, intent(in) :: ltaerosol, convert_dry_rho + logical, intent(in) :: nssl_invertccn real(kind=kind_phys), intent(in ) :: con_pi, dtf real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc @@ -740,6 +759,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ! local variables real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys integer :: i,k,n,tracers,idtend + real(kind=kind_phys) :: liqm, icem, xccn, xcwmas, xccw, xcimas ! , qccn real(kind=kind_phys) :: rho, orho real(kind=kind_phys), dimension(im,levs) :: qv_mp !< kg kg-1 (dry mixing ratio) @@ -806,9 +826,14 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr tracers = 2 do n=2,ntrac ! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc ) then +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & +! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & +! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc & +! .and. & +! n /= nthl .and. n /= nthnc .and. n /= ntgv .and. & +! n /= nthv .and. n /= ntccn & +! ) then + IF ( otsptflag(n) ) THEN tracers = tracers + 1 if(n/=ntk .and. n/=ntlnc .and. n/=ntinc .and. n /= ntcw .and. n /= ntiw) then idtend=dtidx(100+n,index_of_process_conv_trans) @@ -841,6 +866,55 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo enddo + if ( .true. .and. ( imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) ) then + liqm = con_pi/6.*1.e3*(40.e-6)**3 ! 4./3.*con_pi*1.e-12 + icem = con_pi/6.*1.e3*(120.e-6)**3 ! 4./3.*con_pi*3.2768*1.e-14*890. + ! qccn = nssl_cccn/1.225 + do k=1,levs + do i=1,im + ! check number of available ccn + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_invertccn ) THEN + xccn = qccn - gq0(i,k,ntccn) + ELSE + xccn = gq0(i,k,ntccn) + ENDIF + ELSE + xccn = Max(0.0, qccn - gq0(i,k,ntlnc)) + ENDIF + + IF ( gq0(i,k,ntlnc) > 0.0 .and. save_qc(i,k) > 0.0 ) THEN + xcwmas = Max( liqm, clw(i,k,2)/gq0(i,k,ntlnc) ) + ELSE + xcwmas = liqm + ENDIF + + IF ( gq0(i,k,ntinc) > 0.0 .and. save_qi(i,k) > 0.0 ) THEN + xcimas = Max( liqm, clw(i,k,1)/gq0(i,k,ntinc) ) + ELSE + xcimas = icem + ENDIF + + IF ( xccn > 0.0 ) THEN + xccw = Min( xccn, max(0.0, (clw(i,k,2)-save_qc(i,k))) / xcwmas ) + gq0(i,k,ntlnc) = gq0(i,k,ntlnc) + xccw + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_invertccn ) THEN + ! ccn are activated CCN, so add + gq0(i,k,ntccn) = gq0(i,k,ntccn) + xccw + ELSE + ! ccn are unactivated CCN, so subtract + gq0(i,k,ntccn) = gq0(i,k,ntccn) - xccw + ENDIF + ENDIF + ENDIF + + gq0(i,k,ntinc) = gq0(i,k,ntinc) & + + max(0.0, (clw(i,k,1)-save_qi(i,k))) / xcimas + enddo + enddo + endif + if (imp_physics == imp_physics_thompson .and. (ntlnc>0 .or. ntinc>0)) then if_convert_dry_rho: if (convert_dry_rho) then do k=1,levs diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index f596b86cd..33f556193 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1040,6 +1040,22 @@ [ccpp-arg-table] name = GFS_suite_interstitial_3_run type = scheme +[otsptflag] + standard_name = flag_convective_tracer_transport_interstitial + long_name = flag for interstitial tracer transport + units = flag + dimensions = (number_of_tracers_plus_one) + type = logical + intent = in + optional = F +[ntracp1] + standard_name = number_of_tracers_plus_one + long_name = number of tracers plus one + units = count + dimensions = () + type = integer + intent = in + optional = F [im] standard_name = horizontal_loop_extent long_name = horizontal loop extent @@ -1254,6 +1270,22 @@ dimensions = () type = integer intent = in +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [prsi] standard_name = air_pressure_at_interface long_name = air pressure at model layer interfaces @@ -1604,6 +1636,14 @@ dimensions = () type = integer intent = in +[ntccn] + standard_name = index_for_cloud_condensation_nuclei_number_concentration + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -1646,6 +1686,30 @@ dimensions = () type = logical intent = in +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [dtf] standard_name = timestep_for_dynamics long_name = dynamics timestep @@ -1808,6 +1872,22 @@ dimensions = () type = integer intent = in +[otsptflag] + standard_name = flag_convective_tracer_transport_interstitial + long_name = flag for interstitial tracer transport + units = flag + dimensions = (number_of_tracers_plus_one) + type = logical + intent = in + optional = F +[ntracp1] + standard_name = number_of_tracers_plus_one + long_name = number of tracers plus one + units = count + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 1486ac027..10c9ab99e 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -27,7 +27,8 @@ end subroutine maximum_hourly_diagnostics_finalize #endif subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, & imp_physics_gfdl, imp_physics_thompson, & - imp_physics_fer_hires,con_g, phil, & + imp_physics_fer_hires, imp_physics_nssl2m, & + imp_physics_nssl2mccn, con_g, phil, & gt0, refl_10cm, refdmax, refdmax263k, u10m, v10m, & u10max, v10max, spd10max, pgr, t2m, q2m, t02max, & t02min, rh02max, rh02min, dtp, rain, pratemax, & @@ -36,7 +37,8 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, ! Interface variables integer, intent(in) :: im, levs logical, intent(in) :: reset, lradar - integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires + integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires, & + imp_physics_nssl2m, imp_physics_nssl2mccn real(kind_phys), intent(in ) :: con_g real(kind_phys), intent(in ) :: phil(:,:) real(kind_phys), intent(in ) :: gt0(:,:) @@ -73,15 +75,24 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, !Calculate hourly max 1-km agl and -10C reflectivity if (lradar .and. (imp_physics == imp_physics_gfdl .or. & imp_physics == imp_physics_thompson .or. & - imp_physics == imp_physics_fer_hires)) then + imp_physics == imp_physics_fer_hires .or. & + imp_physics == imp_physics_nssl2m .or. & + imp_physics == imp_physics_nssl2mccn)) then allocate(refd(im)) allocate(refd263k(im)) call max_fields(phil,refl_10cm,con_g,im,levs,refd,gt0,refd263k) if (reset) then - do i=1,im - refdmax(i) = -35. - refdmax263k(i) = -35. - enddo + IF ( imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) THEN + do i=1,im + refdmax(i) = 0. + refdmax263k(i) = 0. + enddo + ELSE + do i=1,im + refdmax(i) = -35. + refdmax263k(i) = -35. + enddo + ENDIF endif do i=1,im refdmax(i) = max(refdmax(i),refd(i)) diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index d9a236c29..1a8407ac5 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -63,6 +63,22 @@ dimensions = () type = integer intent = in +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 294e1e018..b6cc715fd 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -108,6 +108,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & + & imp_physics_nssl2m, imp_physics_nssl2mccn, & & ltaerosol, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: @@ -210,7 +211,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_output, & & grav_settling, & & imp_physics, imp_physics_wsm6, & - & imp_physics_thompson, imp_physics_gfdl + & imp_physics_thompson, imp_physics_gfdl, & + & imp_physics_nssl2m, imp_physics_nssl2mccn !TENDENCY DIAGNOSTICS real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) @@ -398,6 +400,33 @@ SUBROUTINE mynnedmf_wrapper_run( & qnifa(i,k) = 0. enddo enddo + elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + ! NSSL + FLAG_QI = .true. + FLAG_QNI= .true. + FLAG_QC = .true. + FLAG_QNC= .true. + FLAG_QNWFA= .false. + FLAG_QNIFA= .false. + p_qc = 2 + p_qr = 0 + p_qi = 2 + p_qs = 0 + p_qg = 0 + p_qnc= 0 + p_qni= 0 + do k=1,levs + do i=1,im + sqv(i,k) = qgrs_water_vapor(i,k) + sqc(i,k) = qgrs_liquid_cloud(i,k) + sqi(i,k) = qgrs_ice_cloud(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) + qnwfa(i,k) = 0. + qnifa(i,k) = 0. + enddo + enddo elseif (imp_physics == imp_physics_thompson) then ! Thompson if(ltaerosol) then diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index e7c107b52..ad877b837 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1257,6 +1257,22 @@ dimensions = () type = integer intent = in +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 new file mode 100644 index 000000000..9b73797c4 --- /dev/null +++ b/physics/module_mp_nssl_2mom.F90 @@ -0,0 +1,19729 @@ +!WRF:MODEL_LAYER:PHYSICS + + +! prepocessed on "Oct 16 2020" at "14:58:00" + + + + + + + + +!--------------------------------------------------------------------- +! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: +! moist_adv_opt = 4, +! scalar_adv_opt = 4, (can also use option 3, which is WENO without the positive definite filter) +! The WENO-5 scheme provides a 5th-order (horizontal and vertical) adaptive weighting of components that +! better preserve monotinicity in strong gradients. The standard 5th-order formulation is prone to undershoots +! (negative values) of mass and number concentrations at cloud edges. The WENO scheme helps +! to prevent undershoots and results in less noise at cloud and reflectivity boundaries. This is particularly +! useful for multi-moment schemes to preserve relationships between mass and number concentration. An option is also available +! for WENO-5 advection of momentum, but this can result in excessive damping of poorly-resolved features. For both scalar and momentum +! the steps 1 and 2 of the Runge-Kutta time integration use standare 5th-order advection, and the WENO-5 is applied on the 3rd (final) +! RK step. Option 3 applies the WENO-5, and option 4 adds the positive definite filter (as also used in option 1). +! +! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; +! +! This module provides a 2-moment bulk microphysics scheme originally +! developed by Conrad Ziegler (Zeigler, 1985, JAS) and modified/upgraded in +! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation +! follows Mansell (2010, JAS), using parameter infall = 4. +! +! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) +! +! Average graupel particle density is predicted, which affects fall speed as well. +! Hail density prediction is by default disabled in this version, but may be enabled +! at some point if there is interest. +! +! Maintainer: Ted Mansell, National Severe Storms Laboratory +! +! Microphysics References: +! +! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small +! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. +! +! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and +! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, +! doi:10.1175/JAS-D-12-0264.1. +! +! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. +! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. +! +! Sedimentation reference: +! +! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. +! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. +! +! Possible parameters to adjust: +! +! ccn : base cloud condensation nuclei concentration (use namelist.input value "nssl_cccn") +! alphah, alphahl : Size distribution shape parameters for graupel (h) and hail (hl) +! infall : changes sedimentation options to see effects (see below) +! +! lightning model references: +! +! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The +! implementation of an explicit charging and discharge lightning scheme +! within the WRF-ARW model: Benchmark simulations of a continental squall line, a +! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 +! +! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated +! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287 +! +! Note: Some parameters below apply to unreleased features. +! +! +!--------------------------------------------------------------------- +! Sept. 2019: +! Bug fixes: +! - Effective radius calculation was only done at history times. Now every time step (though should be just before radiation is called) +! - Snow reflectivity: Previous "fix" was incorrect and yields snow dBZ that is too low. Reverted to old version which was correct +! - Incorrectly updated a state value in the reflectivity code. (Could cause small differences if reflectivity is not calculated) +! Updates: +! - Added code hints to use the "axtra2d" array to communicate rates from the microphysics routine into any 3d arrays that are passed in to the driver. +! - Graupel and hail drag coefficients are returned from fall speed subroutine to use in ventilation coeffs. for consistency (minor change) +! - Added (compile) option flag to turn on diagnosis of cloud droplet shape parameter based on number concentration +! - Added (compile) option flag icracr to turn off rain self-collection +! - Added compile options 'depfac' and 'meltfac' to adjust deposition/sublimation and melting (not freezing) rates of graupel/hail by a constant factor (for experimentation). Default value is 1.0 +! - Put limit on snow volume (2 cm) in aggregation rate +!--------------------------------------------------------------------- +! WRF 4.0 update: +! Major: +! Fixed excessive sublimation that could occur in very strong downdrafts (3.9.1.1 update) +! +! Minor: +! icefallopt=3 : New ice crystal fall speed that has faster speeds for small ice particles. Main effect +! is on anvil clouds to help them decay a bit faster. Old behavior can be recovered with icefallopt=1 +! Cosmetic: removed stray single quotes because some preprocessors complain about unclosed quotes even in comments +! +!--------------------------------------------------------------------- +! WRF 3.9.1.1 update: +! +! Added a check on overdepletion of ice by sublimation, which could sometimes result in water supersaturation +! Bug fix: setting of t7 used 'dn' instead of 'dn1' (Thanks to Chunxi Zhang) +! +!--------------------------------------------------------------------- +! WRF 3.9 updates: +! +! 2-moment scheme now creates number concentration tendencies from cumulus scheme mass mixing ratio rates +! Renamed internal gamma function routine from 'gamma' to 'gamma_sp' to avoid name conflicts +! Restored older settings that allow snow aggregation starting at T > -25C +! Adjusted Meyers number of activated nuclei by the local air density to compensate for using data at surface +! Minor updates to rain-ice crystal and hail-rain collection efficiencies +! +! +! Reduced minimum mean snow diameter from 100 microns to 10 microns +! +!--------------------------------------------------------------------- +! WRF 3.8 updates: +! Fixed issue with reflectivity conservation for graupel melting into rain. Rain number concentrations were too low, +! resulting in excessive reflectivity of a couple dBZ +! Changed default value of iusewetgraupel to 1 (turns off diagnostic meltwater on graupel for reflectivity) +! Apply a 70 m/s fall speed limit for sedimentation +! Changed vapor ice nucleation to Meyers-Ferrier method (original scheme) +! New method for Bigg freezing (ibiggopt=2) +! Reduced snow aggregration efficiency and restricted aggregation to higher temperatures (assuming dendrites and mechanical aggregation) +! Increased maximum graupel-droplet collection efficiency when hail is turned off (nssl_2momg) +! Updates for compatibility with WRF-NMM +! Added calculation of hail number concentration in calcnfromq (creates number concentration from mixing ratio +! when starting from an analysis). And fixed error in graupel intercept +! Bug fix in snow fall speeds +! Further fix in snow reflectivity +! Use diameter of maximum mass rather than mean diamter when checking maximum size +! Helped performance in sedimentation with flag "do_accurate_sedimentation" to control recalculation of fall speeds when +! more than one sub-time step is needed (often happens with large time steps and small dz near the ground): +! = .true. : recalculates fall speed after each substep (more accurate) +! = .false. : (default) reuses fall speeds calculated on the first substep (typical for most schemes), theoretically could cause an occasional glitch, but none seen in practice +! Increased maximum mean droplet radius from 40 to 60 microns, which alleviates spurious number concentration increases at low CCN concentration. +! Removed a duplicate factor from hail reflectivity that was causing a loss of about 6 dBZ (since WRF 3.5). +! +!--------------------------------------------------------------------- + + + +MODULE module_mp_nssl_2mom + + IMPLICIT NONE + + public nssl_2mom_driver + public nssl_2mom_init + public nssl_2mom_init_aero + private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis + private gamma_dp, gamxinfdp, gamma_dpr + private delbk, delabk + private gammadp + + logical, private :: cleardiag = .false. + PRIVATE + +#ifdef WRF_CHEM + integer, parameter :: wrfchem_flag = 1 +#else + integer, parameter :: wrfchem_flag = 0 +#endif + + LOGICAL, PRIVATE:: is_aerosol_aware = .false. +! From ThompsonAero: +! Declaration of constants for assumed CCN/IN aerosols when none in +! the input data. Look inside the init routine for modifications +! due to surface land-sea points or vegetation characteristics. + REAL, PARAMETER, PRIVATE:: naIN0 = 1.5E6 + REAL, PARAMETER, PRIVATE:: naIN1 = 0.5E6 + REAL, PARAMETER, PRIVATE:: naCCN0 = 300.0E6 + REAL, PARAMETER, PRIVATE:: naCCN1 = 50.0E6 + + logical, private :: turn_on_cin = .false. + + integer, private :: eqtset = 1 ! Flag for use with cm1 to use alternate equation set (changes latent heating rates) + ! value of > 2 invokes the equivalent version of eqtset=2 that applies updates to both theta and Pi. + double precision, parameter, public :: zscale = 1.0d0 ! 1.000e-10 + double precision, parameter, public :: zscaleinv = 1.0d0/zscale ! 1.000e-10 + + + real, parameter :: warmonly = 0.0 ! testing parameter, set to 1.0 to reduce to warm-rain physics (ice variables stay zero) + + logical, parameter :: lwsm6 = .false. ! act like wsm6 for some single moment interactions + +! some constants from WSM6 + real, parameter :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter + real, parameter :: roqimax = 2.08e22*dimax**8 + +! Params for dbz: + integer :: iuseferrier = 1 ! =1: use dry graupel only from Ferrier 1994; = 0: Use Smith (wet graupel) + integer :: idbzci = 1 + integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + ! =2 turn on for graupel density less than 300. only + integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + integer :: iusewetsnow = 1 ! =1 to turn on diagnosed bright band + +! microphysics + + real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params + real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params + real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params + real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params + + real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel) + real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail) + + real :: cnohmn = 1.e-2 ! minimum intercept for 2-moment graupel (alphah < 0.5) + real :: cnohlmn = 1.e-2 ! minimum intercept for 2-moment hail (alphahl < 0.5) + +! Autoconversion parameters + + real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5) + real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion) + real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) + real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value + real , public :: qccn ! ccn "mixing ratio" + integer, private :: iauttim = 1 ! 10-ice rain delay flag + real , private :: auttim = 300. ! 10-ice rain delay time + real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual + +!#if (NMM_CORE == 1) +! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true +! logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state +!#else + logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state +!#endif + logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) + real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) + + +! sedimentation flags +! itfall -> 0 = 1st order fallout (other options removed) +! iscfall, infall -> fallout options for charge and number concentration, respectively +! 1 = mass-weighted fall speed; 2 = number-weighted fallspeed. + integer, private :: itfall = 0 + integer, private :: iscfall = 1 + integer, private :: irfall = -1 + logical, private :: do_accurate_sedimentation = .false. ! if true, recalculate fall speeds on sub time steps; (more expensive) + ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) + ! Mainly is an issue for small dz near the surface. + integer, private :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) + ! 1 -> uses mass-weighted fallspeed for N ALWAYS + ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS) + ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) + ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) + ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. + real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) + real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed + real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed + real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed + real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed + integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) + integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4) + real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4) + real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4) + real , private :: cdhldnmin = 500., cdhldnmax = 800.0 ! defaults for hail (icdx=4) + real , private :: vtmaxsed = 70. ! Limit on fall speed (m/s, all moments) for sedimentation calculations. Not applied to fall speeds for microphysical rates + + integer :: rssflg = 1 ! Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value + integer :: sssflg = 1 ! As above but for snow + integer :: hssflg = 1 ! As above but for graupel + integer :: hlssflg = 1 ! As above but for hail + +! input flags + + integer, private :: ndebug = -1, ncdebug = 0 + integer, private :: ipconc = 5 + integer, private :: ichaff = 0 + integer, parameter :: ilimit = 0 + + real, private :: constccw = -1. + + real, private :: cimn = 1.0e3, cimx = 1.0e6 + + + real , private :: ifrzg = 1.0 ! fraction of frozen drops (Bigg freezing) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail + real , private :: ifiacrg = 1.0 ! fraction of frozen drops (3-component freezing qiacr) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail + real , private :: ifrzs = 1.0 ! fraction of small frozen drops going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + real , private :: ffrzs = 0.0 ! fraction of other initiated cloud ice going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget) + integer, private :: irimtim = 0 ! future use +! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds + + integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993) + real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985) + real , private :: rimc3 = 170.0 ! minimum rime density + real :: rimc4 = 900.0 ! maximum rime density + real , private :: rimtim = 120.0 ! cut-off rime time (10ICE) + real , private :: eqtot = 1.0e-9 ! threshold for mass budget reporting + real, private :: rimdenvwgt = 0.0 ! weight (0-1) given to number-weighted fall speed when calculating rime density + + integer, private :: ireadmic = 0 + + integer, private :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data + integer, private :: iccwflg = 1 ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid) + ! (first nucleation is done with a KW sat. adj. step) + integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field + integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) + integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud + ! =2 renucleation following Twomey/Cohard&Pinty + ! =7 New renucleation that requires prediction of the number of activated nuclei + ! i.e., not only at cloud base + integer, private :: irenuc3d = 0 ! =1 to include horizontal gradient in renucleation of droplets within the cloud + real :: renucfrac = 0.0 ! = 0 : cnuc = cwccn + ! = 1 : cnuc = actual available CCN + ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac + real :: ssf2kmax = 1.05 ! max value for ssf**cck in irenuc=4 + real , private :: cck = 0.6 ! exponent in Twomey expression + real , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation + + real , private :: cwccn ! , cwmasn,cwmasx + real , private :: ccwmx + + integer, private :: idocw = 1, idorw = 1, idoci = 1, idoir = 1, idoip = 1, idosw = 1 + integer, private :: idogl = 1, idogm = 1, idogh = 1, idofw = 1, idohw = 1, idohl = 1 +! integer, private :: ido(3:14) = / 12*1 / + + +! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr + integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process + integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010) + real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott + integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version + integer, private :: ihrn = 0 ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only) + integer, private :: ibfc = 1 ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on) + real, private :: cwfrz2snowfrac = 0.0 ! fraction of freezing droplet mass to send to snow + real, private :: cwfrz2snowratio = 5. ! Assumed number of frozen droplets in a cluster + integer, private :: iremoveqwfrz = 1 ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation + integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals + ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron) + integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off) + integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel + ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation) + integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) + integer :: ibiggsmallrain = 0 ! 1 = When rain is too small, freeze none to graupel and send all to snow (experimental) + integer, private :: iacrsize = 5 ! assumed min size of drops freezing by capture + ! 1: > 500 micron diam + ! 2: > 300 micron + ! 3: > 40 micron + ! 4: all sizes + ! 5: > 150 micron (only for imurain = 1) + real , private :: cimas0 = 6.62e-11 ! default mass of Hallett-Mossop crystals + ! 6.62e-11kg results in half the diam. (60 microns) of old default value of 5.0e-10 + real , private :: cimas1 = 6.88e-13 ! default mass of new ice crystals + real , private :: splintermass = 6.88e-13 + real , private :: cfnfac = 0.1 ! Hack factor that goes with icfn=1 + integer, private :: iscni = 4 ! default option for ice crystal aggregation/conversion to snow + real , private :: fscni = 1.0 ! factor for calculating cscni + logical, private :: imeyers5 = .false. ! .false.=off, true=on for Meyers ice nucleation for temp > -5 C + real , private :: dmincw = 15.0e-6 ! minimum droplet diameter for collection for iehw=3 + integer, private :: iehw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data + integer, private :: iehlw = 1 ! 0 -> ehlw=ehlw0; 1 -> old ehlw; 2 -> test ehlw with Mason table data + ! For ehw/ehlw = 1, ehw0/ehlw0 act as maximum limit on collection efficiency (defaults are 1.0) + integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) + integer, private :: iehr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + integer, private :: iehlr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + real , private :: ehw0 = 0.9 ! constant or max assumed graupel-droplet collection efficiency + real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency + real , private :: ehlw0 = 0.9 ! constant or max assumed hail-droplet collection efficiency + real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency + real :: ehlr0 = 1.0 ! constant or max assumed hail-rain collection efficiency + real , private :: exwmindiam = 0.0 ! minimum diameter of droplets for riming. If set > 0, will exclude that fraction of mass/number from accretion (idea from Furtado and Field 2017 JAS but also Fierro and Mansell 2017) + + + real , private :: esilfo0 = 1.0 ! factor for LFO collection efficiency of snow for cloud ice. + real , private :: ehslfo0 = 1.0 ! factor for LFO collection efficiency of hail/graupel for snow. + + integer, private :: ircnw = 5 ! single-moment warm-rain autoconversion option. 5= Ferrier 1994. + real , private :: qminrncw = 2.0e-3 ! qc threshold for rain autoconversion (NA for ircnw=5) + + integer, private :: iqcinit = 2 ! For ZVDxx schemes, flag to choose which way to initialize droplets + ! 1 = Soong-Ogura adjustment + ! 2 = Saturation adjustment to value of ssmxinit + ! 3 = KW adjustment + + real , private :: ssmxinit = 0.4 ! saturation percentage to adjust down to for initial cloud + ! formation (ZVDxx scheme only) + + real , private :: ewfac = 1.0 ! hack factor applied to graupel and hail collection eff. for droplets + real , private :: eii0 = 0.1 ,eii1 = 0.1 ! graupel-crystal coll. eff. parameters: eii0*exp(eii1*min(temcg(mgs),0.0)) + ! set eii1 = 0 to get a constant value of eii0 + real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) + ! set eii1hl = 0 to get a constant value of eii0hl + real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals + real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain + real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency + real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) + ! set ehs1 = 0 to get a constant value of ehs0 + real , private :: ess0 = 1.0, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) + ! set ess1 = 0 to get a constant value of ess0 + real , private :: esstem1 = -25. ! lower temperature where snow aggregation turns on + real , private :: esstem2 = -20. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + real , private :: essrmax = 0.02 ! maximum snow radius (meters) for csacs + real , private :: essfrac1 = 0.5 ! snow mass fraction 1 for aggregation roll-off + real , private :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off + integer, private :: iessec0flag = 0 ! flag to activate aggregation roll-off + real , private :: ehsfrac = 1.0 ! multiplier for graupel collection efficiency in wet growth + real , private :: ehimin = 0.0 ! Minimum collection efficiency (graupel - ice crystal) + real , private :: ehimax = 1.0 ! Maximum collection efficiency (graupel - ice crystal) + real , private :: ehsmax = 0.5 ! Maximum collection efficiency (graupel - snow) + real , private :: ecollmx = 0.5 ! Maximum collision efficiency for graup/hail with ice; used only for charging rates + integer, private :: iglcnvi = 1 ! flag for riming conversion from cloud ice to rimed ice/graupel + integer, private :: iglcnvs = 2 ! flag for conversion from snow to rimed ice/graupel + + real , private :: rz ! reflectivity conservation factor for graupel/rain + ! now calculated in icezvd_dr.F from alphah and rnu + ! currently only used for graupel melting to rain + real , private :: rzhl ! reflectivity conservation factor for hail/rain + ! now calculated in icezvd_dr.F from alphahl and rnu + + real , private :: rzs ! reflectivity conservation factor for snow(imusnow=3) with rain (imurain=1) + + real , private :: alphahacx = 0.0 ! assumed minimum shape parameter for zhacw and zhacr + + real , private :: fconv = 1.0 ! factor to boost max graupel depletion by riming conversions in 10ICE + + real , private :: rg0 = 400.0 ! reference graupel density for graupel fall speed + + integer, private :: rcond = 2 ! (Z only) rcond = 2 includes rain condensation in loop with droplet condensation + ! 0 = no condensation on rain; 1 = bulk condensation on rain + integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation + ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.) + + real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 + ! and for ciacrf for iacr=4 + real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail + real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail + + integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail + integer, private :: imltshddmr = 2 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail + ! and max mean diameter of rain) + ! 1=new method where mean diameter of rain during melting is adjusted linearly downward + ! toward 3 mm for large (> sheddiam) graupel and hail, to take into account shedding of + ! smaller drops. sheddiam0 controls the size of graupel/hail above which the assumed + ! mean diameter of rain is set to 3 mm + ! Only valid for ihmlt = 2 for ZVD(H) but also applies to ZVD(H)M + ! 2 = method that sets the resulting rain size ( vshdgs ) according to the mass-weighted diameter of the ice + + real :: mltdiam1 = 9.0e-3, mltdiam2 = 16.0e-3, mltdiam3 = 19.0e-3, mltdiam4 = 200.0e-3, mltdiam05 = 4.5e-3 + + integer, private :: nsplinter = 0 ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle + real, private :: lawson_splinter_fac = 2.5e-11 ! constant in Lawson et al. (2015, JAS) for ice particle production from freezing drops + integer, private :: isnwfrac = 0 ! 0= no snow fragmentation; 1 = turn on snow fragmentation (Schuur, 2000) + +! integer, private :: denscale = 1 ! 1=scale num. conc. and charge by air density for advection, 0=turn off for comparison + + real, private :: qhdpvdn = -1. + real, private :: qhacidn = -1. + + logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel + integer, private :: imixedphase = 0 + logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density + logical, private :: qhdenmod = .false. ! true = modify graupel density by linear interpolation of graupel and rain density + logical, private :: qsvtmod = .false. ! true = modify snow fall speed by linear interpolation of snow and rain vt + real , private :: sheddiam = 8.0e-03 ! minimum diameter of graupel before shedding occurs + real :: sheddiamlg = 10.0e-03 ! diameter of hail to use fwmlarge + real :: sheddiam0 = 20.0e-03 ! diameter of hail at which all water is shed + + integer :: ifwmhopt = 2 ! option for calculating maximum liquid fraction when fwmh and/or fwmhl is set to -1 + ! 1 = maximum based on size of maximum mass diameter + ! 2 = integrate over spectrum for maximum liquid (experimental) + + integer :: ihxw2rain = 0 ! = 0 no transfer + ! = 1 transfer completely melted (99.5%) graupel/hail to rain when fwmh/fwmhl is set to -1. + + real , private :: fwms = 0.5 ! maximum liquid water fraction on snow + real , private :: fwmh = 0.5 ! maximum liquid water fraction on graupel + real , private :: fwmhl = 0.5 ! maximum liquid water fraction on hail + real :: fwmlarge = 0.2 ! maximum liquid water fraction on hail larger than sheddiam + integer :: ifwmfall = 0 ! whether to interpolate toward rain fall speed for graupel and hail + ! when diam < sheddiam and liquid fraction is predicted (0=no, 1=yes) + + logical :: rescale_high_alpha = .false. ! whether to rescale number. conc. when alpha = alphamax (3-moment only) + logical :: rescale_low_alpha = .true. ! whether to rescale Z (graupel/hail) when alpha = alphamin (3-moment only) + logical :: rescale_low_alphar = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphah = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphahl = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + + real, parameter :: alpharmax = 8. ! limited for rwvent calculation + + integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use + ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter + ! 2 = Straka and Mansell (2005) conversion using size threshold + real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. + real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) + real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on) + real , private :: dwmin = 0.0 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail + real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) + real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed + + integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. + integer, private :: imusnow = 3 ! 3 for gamma-volume, 1 for gamma-diameter DSD for snow (=1 NOT IMPLEMENTED!!). + integer, private :: iturbenhance = 0 ! warm-rain collision enhancement + ! 1 = enhance autoconversion only + ! 2 = add rain collection of cloud + ! 3 = add rain self-collection + integer, private :: isedonly = 0 ! 1= only do sedimentation and skip other microphysics + integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1) + integer, private :: izwisventr = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3) + integer :: iresetmoments = 0 ! if >0, then set all moments to zero when one of them is zero (3-moment only) + integer, private :: imaxdiaopt = 3 + ! = 1 use mean diameter for breakup + ! = 2 use maximum mass diameter for breakup + ! = 3 use mass-weighted diameter for breakup + integer, private :: dmrauto = 0 + ! = -1 no limiter on crcnw + ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) + ! = 1 DTD version based on MY code + ! = 2 DTD mass-weighted version based on MY code + ! = 3 Milbrandt version (from Cohard and Pinty code + integer :: dmropt = 0 ! extra option for crcnw + integer :: dmhlopt = 1 ! options for graupel -> conversion + integer :: irescalerainopt = 3 ! 0 = default option + ! 1 = qx(mgs,lc) > qxmin(lc) + ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 + ! 3 = temcg(mgs) > 0.0.and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 + real :: rescale_wthresh = 3.0 + real :: rescale_tempthresh = 0.0 + real, parameter :: alpharaut = 0.0 ! MY2005 for autoconversion + real :: cxmin = 1.e-8 ! threshold cutoff for number concentration + real :: zxmin = 1.e-28 ! threshold cutoff for reflectivity moment + + integer :: ithompsoncnoh = 0 ! For single moment graupel only + ! 0 = fixed intercept + ! 1 = intercept based on graupel mass + + integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting + ! when liquid fraction is not predicted + integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories + integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters + ! 1 = original Zrnic et al. (Mansell et al. 2010) + ! 2 = Ferrier 1994 (results in slower fall speeds) + + integer, private :: isnowdens = 1 ! Option for choosing between snow density options + ! 1 = constant of 100 kg m^-3 + ! 2 = Option based on Cox + + integer, private :: ibiggsnow = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing + ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction + ! 3 = switch conversion over to snow for small frozen drops from both + + integer, private :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi) + + real, private :: takshedsize1 = 0.15 ! diameter (cm) of drop shed from ice with D > 1.9 cm + real, private :: takshedsize2 = 0.3 ! diameter (cm) of drop shed from ice with D < 1.9 cm and D > 0.8 cm + real, private :: takshedsize3 = 0.45 ! diameter (cm) of drop shed from ice with D < 1.6 cm and D > 0.8 cm + integer, private :: numshedregimes = 3 + + real, private :: evapfac = 1.0 ! Multiplier on rain evaporation rate + real, private :: depfac = 1.0 ! Multiplier on graupel/hail deposition/sublimation rate + real,private,parameter :: meltfac = 1.0 ! Multiplier on graupel/hail melting rate + + integer, private :: ibinhmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of graupel, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + integer, private :: ibinhlmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of hail, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1) + integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr + integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr + real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr + real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting + real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow. + real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter + + integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau) + + integer :: imaxsupopt = 4 ! how to treat saturation adjustment in two-moment droplets + ! 1 = add droplets with same mean mass as current droplets + ! 2 = add droplets with minimum radius of 30 microns + ! 3 = only add 1.5*cxmin to number concentration (allow max size to apply) + ! 4 = add droplets with minimum radius of 20 microns + real :: maxsupersat = 1.9 ! maximum supersaturation ratio, above which a saturation adustment is done + real :: ssmxuf = 4.0 ! supersaturation at which to start using "ultrafine" CCN (if ccnuf > 0.) + + + integer, parameter :: icespheres = 0 ! turn ice spheres (frozen droplets) on (1) or off (0). NOT COMPLETE IN WRF/ARPS/CM1 CODE! + integer, parameter :: lqmx = 30 + integer, parameter :: lt = 1 + integer, parameter :: lv = 2 + integer, parameter :: lc = 3 + integer, parameter :: lr = 4 + integer, parameter :: li = 5 + integer, private :: lis = 0 + integer, private :: ls = 6 + integer, private :: lh = 7 + integer, private :: lhl = 0 + + integer, private :: lccn = 9 ! 0 or 9, other indices adjusted accordingly + integer, private :: lccnuf = 0 + integer, private :: lccna = 0 + integer, private :: lcina = 0 + integer, private :: lcin = 0 + integer, private :: lnc = 9 + integer, private :: lnr = 10 + integer, private :: lni = 11 + integer, private :: lnis = 0 + integer, private :: lns = 12 + integer, private :: lnh = 13 + integer, private :: lnhl = 0 + integer, private :: lss = 0 + integer :: lvh = 15 + + integer, private :: lhab = 8 + integer, private :: lg = 7 + +! Particle volume + + integer :: lvi = 0 + integer :: lvs = 0 + integer :: lvgl = 0 + integer :: lvgm = 0 + integer :: lvgh = 0 + integer :: lvf = 0 +! integer :: lvh = 16 + integer :: lvhl = 0 + +! liquid water fraction (not predicted here but tested for) + integer :: lhw = 0 + integer :: lsw = 0 + integer :: lhlw = 0 + integer :: lhwlg = 0 + integer :: lhlwlg = 0 + +! reflectivity (6th moment) ! not predicted here but may be tested against + + integer :: lzr = 0 + integer :: lzi = 0 + integer :: lzs = 0 + integer :: lzgl = 0 + integer :: lzgm = 0 + integer :: lzgh = 0 + integer :: lzf = 0 + integer :: lzh = 0 + integer :: lzhl = 0 + +! Space charge + + integer :: lscw = 0 + integer :: lscr = 0 + integer :: lsci = 0 + integer :: lscis = 0 + integer :: lscs = 0 + integer :: lsch = 0 + integer :: lschl = 0 + integer :: lscwi = 0 + integer :: lscpi = 0 + integer :: lscni = 0 + integer :: lscpli = 0 + integer :: lscnli = 0 + integer :: lschab = 0 + + integer :: lscb = 0 + integer :: lsce = 0 + integer :: lsceq = 0 + +! integer, parameter :: lscmx = 100 + + integer :: lne = 0 ! last varible for transforming + + real :: cnoh0 = 4.0e+5 + real :: hwdn1 = 700.0 + + real :: alphai = 0.0 ! shape parameter for ZIEG ice crystals ! not currently used + real :: alphas = 0.0 ! shape parameter for ZIEG snow ! used only for single moment + real :: alphar = 0.0 ! shape parameter for rain (imurain=1 only) + real, private :: alphah = 0.0 ! set in namelist!! shape parameter for ZIEG graupel + real, private :: alphahl = 1.0 ! set in namelist!! shape parameter for ZIEG hail + + real :: dmuh = 1.0 ! power in exponential part (graupel) + real :: dmuhl = 1.0 ! power in exponential part (hail) + + real, private :: alphamax = 15. + real, private :: alphamin = 0. + real, parameter :: rnumin = -0.8 + real, parameter :: rnumax = 15.0 + + + real :: cnu = 0.0 ! default value of droplet shape parameter. Can be diagnosed by setting idiagnosecnu=1 + real, parameter :: rnu = -0.8, snu = -0.8, cinu = 0.0 +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + + real xnu(lc:lqmx) ! 1st shape parameter (mass) + real xmu(lc:lqmx) ! 2nd shape parameter (mass) + real dnu(lc:lqmx) ! 1st shape parameter (diameter) + real dmu(lc:lqmx) ! 2nd shape parameter (diameter) + + real ax(lc:lqmx) + real bx(lc:lqmx) + real fx(lc:lqmx) + + real da0 (lc:lqmx) ! collection coefficients from Seifert 2005 + real dab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real dab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real da1 (lc:lqmx) ! collection coefficients from Seifert 2005 + real bb (lc:lqmx) + +! put ipelec here for now.... + integer :: ipelec = 0 + integer :: isaund = 0 + logical :: idoniconly = .false. + integer, private :: elec_on_time = -1 ! time (seconds) to turn on charge separation. + integer, private :: elec_ramp_time = 0 ! time (interval) for linear ramp after elec_on_time + ! (i.e., linear factor on chg sep to smoothly turn on elec) + ! full charging rate is achieved at time = elec_on_time + elec_ramp_time + integer :: jchgs = 3 ! number of points near boundary where charging is turned off (to keep lightning from getting wonky) + integer :: jchgn = 2 + integer :: ichge = 3 + integer :: ichgw = 2 + real :: charging_border = 4000. ! width of no-charging zone from boundary + real, private :: delqnw = -1.0e-10!-1.0e-12 ! + real, private :: delqxw = 1.0e-10! 1.0e-12 ! + real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed + +! +! gamma function lookup table +! + integer ngm0,ngm1,ngm2 + parameter (ngm0=3001,ngm1=500,ngm2=500) + double precision, parameter :: dgam = 0.01, dgami = 100. + double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) + + integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15 + integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25 +! real, parameter :: maxratiolu = 25. + real, parameter :: maxratiolu = 100. ! 25. + real, parameter :: maxalphalu = 15. + real, parameter :: minalphalu = -0.95 + real, parameter :: dqiacralpha = maxalphalu/Float(nqiacralpha), dqiacrratio = maxratiolu/Float(nqiacrratio) + real, parameter :: dqiacrratioinv = 1./dqiacrratio, dqiacralphainv = 1./dqiacralpha + integer, parameter :: ialpstart = minalphalu*dqiacralphainv + real :: ciacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + real :: qiacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + real :: ziacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) +! real :: ciacrratio(0:nqiacrratio,0:nqiacralpha) +! real :: qiacrratio(0:nqiacrratio,0:nqiacralpha) +! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) +! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) + + integer, parameter :: ngdnmm = 9 + real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail + + DATA mmgraupvt(:,1) / 50., 150., 250., 350., 450., 550., 650., 750., 850./ + DATA mmgraupvt(:,2) / 62.923, 94.122, 114.74, 131.21, 145.26, 157.71, 168.98, 179.36, 189.02 / + DATA mmgraupvt(:,3) / 0.67819, 0.63789, 0.62197, 0.61240, 0.60572, 0.60066, 0.59663, 0.59330, 0.59048 / + + integer lsc(lc:lqmx) + integer ln(lc:lqmx) + integer ipc(lc:lqmx) + integer lvol(lc:lqmx) + integer lz(lc:lqmx) + integer lliq(li:lqmx) + integer denscale(lc:lqmx) ! flag for density scaling (mixing ratio conversion) + + integer ido(lc:lqmx) + logical ldovol + + real xdn0(lc:lqmx) + real xdnmx(lc:lqmx), xdnmn(lc:lqmx) + real cdx(lc:lqmx) + real cno(lc:lqmx) + real xvmn(lc:lqmx), xvmx(lc:lqmx) + real qxmin(lc:lqmx) + + integer nqsat + parameter (nqsat=1000001) ! (nqsat=20001) + real fqsat,fqsati + parameter (fqsat=0.002,fqsati=1./fqsat) + real tabqvs(nqsat),tabqis(nqsat),dtabqvs(nqsat),dtabqis(nqsat) + +! +! constants +! + real, parameter :: cp608 = 0.608 ! constant used in conversion of T to Tv + real, parameter :: ar = 841.99666 ! rain terminal velocity power law coefficient (LFO) + real, parameter :: br = 0.8 ! rain terminal velocity power law coefficient (LFO) + real, parameter :: aradcw = -0.27544 ! + real, parameter :: bradcw = 0.26249e+06 ! + real, parameter :: cradcw = -1.8896e+10 ! + real, parameter :: dradcw = 4.4626e+14 ! + real, parameter :: bta1 = 0.6 ! beta-1 constant used for ice nucleation by deposition (Ferrier 94, among others) + real, parameter :: cnit = 1.0e-02 ! No for ice nucleation by deposition (Cotton et al. 86) + real, parameter :: dragh = 0.60 ! coefficient used to adjust fall speed for hail versus graupel (Pruppacher and Klett 78) + real, parameter :: dnz00 = 1.225 ! reference/MSL air density + real, parameter :: rho00 = 1.225 ! reference/MSL air density +! cs = 4.83607122 ! snow terminal velocity power law coefficient (LFO) +! ds = 0.25 ! snow terminal velocity power law coefficient (LFO) +! new values for cs and ds + real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient + real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient + real, parameter :: pi = 3.141592653589793 + real, parameter :: piinv = 1./pi + real, parameter :: pid4 = pi/4.0 + + real, parameter :: gr = 9.8 + +! +! max and min mean volumes +! + real xvrmn, xvrmx0 ! min, max rain volumes + real xvsmn, xvsmx ! min, max snow volumes + real xvfmn, xvfmx ! min, max frozen drop volumes + real xvgmn, xvgmx ! min, max graupel volumes + real xvhmn, xvhmn0, xvhmx, xvhmx0 ! min, max hail volumes + real xvhlmn, xvhlmx ! min, max lg hail volumes + + real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3 + real, parameter :: dhmn0 = 0.3e-3 + real, private :: dhmn = dhmn0, dhmx = -1. + + real, parameter :: cwradn = 2.5e-7, xcradmn = cwradn ! minimum radius + real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius + real, parameter :: cwc1 = 6.0/(pi*1000.) + +! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius + real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius + real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius + real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13 + + real, parameter :: xvimn=0.523599*(2.*5.e-6)**3 ! mks min volume = 5 micron radius + real, parameter :: xvimx=0.523599*(2.*1.e-3)**3 ! mks max volume = 1 mm radius (solid sphere approx) + + real, private :: xvdmx = -1.0 ! 3.0e-3 + real :: xvrmx + parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvsmn=0.523599*(0.01e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 ) ! mks xvfmx = (pi/6)*(20mm)**3 + parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx=0.523599*(dhlmx)**3 ) ! mks xvfmx = (pi/6)*(40mm)**3 + +! +! electrical permitivity of air C / (N m**2) - check the units +! + real eperao + parameter (eperao = 8.8592e-12 ) + + real ec,eci ! fundamental unit of charge + parameter (ec = 1.602e-19) + parameter (eci = 1.0/ec) + + real :: scwppmx = 20.0e-12 + real :: scippmx = 20.0e-12 +! +! constants +! + real, parameter :: c1f3 = 1.0/3.0 + + real, parameter :: cai = 21.87455 + real, parameter :: caw = 17.2693882 + real, parameter :: cbi = 7.66 + real, parameter :: cbw = 35.86 + + real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation + real, parameter :: cawbolton = 17.67 + + real, parameter :: tfr = 273.15, tfrh = 233.15 + + real, parameter :: cp = 1004.0, rd = 287.04 + real, parameter :: cpi = 1./cp + real, parameter :: cap = rd/cp, poo = 1.0e+05 + + real, parameter :: rw = 461.5 ! gas const. for water vapor + real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) + real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc + real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity + real, parameter :: tfrcbw = tfr - cbw + real, parameter :: tfrcbi = tfr - cbi + + ! GHB: Needed for eqtset=2 in cm1 +! REAL, PRIVATE :: cv = cp - rd + real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air + REAL, PRIVATE, parameter :: cvv = 1408.5 + REAL, PRIVATE, parameter :: cpl = 4190.0 + REAL, PRIVATE, parameter :: cpigb = 2106.0 + ! GHB + + real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) + real :: ventr, ventrn, ventc, c1sw + + + real :: cckm,ccne,ccnefac,cnexp,CCNE0 + + integer :: na = 9 + integer :: nxtra = 1 + real gf4p5, gf4ds, gf4br + real gsnow1, gsnow53, gsnow73 + real gfcinu1, gfcinu1p47, gfcinu2p47 + real gfcinu1p22,gfcinu2p22 + real gfcinu1p18,gfcinu2p18 + + real :: cwchtmp0 = 1.0 + real :: cwchltmp0 = 1.0 + + real :: esctot = 1.0e-13 + + integer iexy(lc:lqmx,lc:lqmx) + integer :: ieswi = 1, ieswc = 1, ieswr = 0 + integer :: iehlsw = 1, iehli = 1, iehlc = 1, iehlr = 0 + integer :: iehwsw = 1, iehwi = 1, iehwc = 1, iehwr = 0 + + logical, parameter :: do_satadj_for_wrfchem = .true. + + + NAMELIST /nssl_mp_params/ & + ndebug, ncdebug,& + iusewetgraupel, & + iusewethail, & + iusewetsnow, & + idbzci, & + vtmaxsed, & + itfall,iscfall, & + infall, & + rssflg, & + sssflg, & + hssflg, & + hlssflg, & + irimdenopt,rimdenvwgt, & + rimc1, rimc2, rimc3, rimc4, & + idiagnosecnu, & + icnuclimit, & + irenuc, & + restoreccn, ccntimeconst, cck, & + ciintmx, & + itype1, itype2, & + icenucopt, & + naer, & + icfn, & + ibfc, iacr, icracr, & + cwfrz2snowfrac, cwfrz2snowratio, & + ibfr, & + ibiggopt, & + ibiggsmallrain, & + ifrzg,ifiacrg, & + ifrzs,ffrzs, & + iacrsize, & + cimas0, cimas1, cfnfac, & + splintermass, & + ewfac, & + eii0, eii1, & + eri0, esi0, & + eri_cimin, & + eii0hl, eii1hl, & + ehs0, ehs1, & + ess0, ess1, & + esstem1,esstem2, & + ircnw, qminrncw,& ! single-moment only + iglcnvi, & + iglcnvs, & + alphahacx, & + fconv, & + eqtot, & + imeyers5, & + iehw, & + ierw, & + iehr0c,iehlr0c, & + alphai, & + alphar, & + alphas, & ! note that alphah and alphahl come through physics namelist + cnu, & + iscni,fscni, & + dfrz, & + dmlt, & + rainfallfac, & + icefallfac, & + snowfallfac, & + graupelfallfac, & + hailfallfac, & + icefallopt, & + icdx,icdxhl, & + cdhmin, cdhmax, & + cdhdnmin, cdhdnmax, & + cdhlmin, cdhlmax, & + cdhldnmin, cdhldnmax, & + ihmlt, & + ehimin, & + ehimax, & + ehsmax, & + ecollmx, & + ehw0, ehlw0, & + ehr0, ehlr0, & + erw0, & + exwmindiam, & + nsplinter, & + lawson_splinter_fac, & + iqcinit, & + ssmxinit, & + xvdmx, & + dhmn, dhmx, & + fwms,fwmh,fwmhl, & + ifwmhopt, & + ihxw2rain, & + fwmlarge, & + ifwmfall, & + iturbenhance, & + qsdenmod,qhdenmod, & + qsvtmod, & + alphamin,alphamax, & + isnwfrac, & + rescale_low_alpha, & + rescale_low_alphar, & + rescale_low_alphah, & + rescale_low_alphahl, & + rescale_high_alpha, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, & + icvhl2h, hldnmn,hdnmn, & + hlcnhdia, hlcnhqmin, & + isedonly, & + iresetmoments, & + cxmin, zxmin, & + imurain, & + iferwisventr, & + izwisventr, & + qhdpvdn, & + qhacidn, & + sheddiam,sheddiamlg, & + sheddiam0, & + mltdiam1,mltdiam2,mltdiam3,mltdiam4,mltdiam05, & + imaxdiaopt, & + ithompsoncnoh, & + cnohmn, & + ivhmltsoak, & + ioldlimiter, & + isnowfall, & + isnowdens, & + ibiggsnow, & + ixtaltype, & + evapfac, & + depfac, & + dmrauto,irescalerainopt, dmropt,dmhlopt, & + rescale_tempthresh, rescale_wthresh, & + ibinhmlr,ibinhlmlr,imltshddmr, binmlrmxdia, binmlrzrrfac,ibinnum, & + iqhacrmlr, iqhlacrmlr, & + snowmeltdia, & + delta_alphamlr, & + iqvsopt, & + maxsupersat, & + charging_border + +! ##################################################################### +! ##################################################################### + + CONTAINS + +! ##################################################################### +! ##################################################################### + + SUBROUTINE wrf_debug( level, message ) + implicit none + integer :: level + character(*) :: message + + IF ( level < 0 ) THEN + write(0,*) message + ENDIF + + END SUBROUTINE wrf_debug + +! +! ##################################################################### +! + SUBROUTINE wrf_message( message ) + implicit none + character(*) :: message + + write(0,*) message + + END SUBROUTINE wrf_message + +! +! ##################################################################### +! + SUBROUTINE wrf_error_fatal( message ) + ! USE COMMASMPI_MODULE, only: commasmpi_abort + implicit none + character(*) :: message + + write(0,*) message + ! call commasmpi_abort() + + END SUBROUTINE wrf_error_fatal + +! +! ##################################################################### +! + + REAL FUNCTION fqvs(t) + implicit none + real :: t + fqvs = exp(caw*(t-273.15)/(t-cbw)) + END FUNCTION fqvs + + REAL FUNCTION fqis(t) + implicit none + real :: t + fqis = exp(cai*(t-273.15)/(t-cbi)) + END FUNCTION fqis + + + + +! ##################################################################### +! ArcHyperbolic tangent to handle only positive values of argument + + REAL FUNCTION myatanh(x) + implicit none + real :: x + + IF ( x >= 0.0 .and. x < 1.0 ) THEN + myatanh = 0.5*( Log((x + 1.0)/(1. - x))) ! 0.5*( Log(x + 1.0) - Log(1. - x)) + ELSEIF ( x >= 1.0 ) THEN + myatanh = 1.e32 + ELSE + myatanh = 0 + ENDIF + + END FUNCTION myatanh + +! ##################################################################### +! ##################################################################### + SUBROUTINE nssl_2mom_init_aero(hgt, nwfa2d, nwfa, nifa, qnn2d, qnn, dx, dy, cccn, & + is_start, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) + +! This subroutine code is mostly borrowed from thompson_init in module_mp_thompson.F +! Here, it is a separate initialization only of things related to aerosols + + IMPLICIT NONE + + INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: hgt + +!..OPTIONAL variables that control application of aerosol-aware scheme + + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), OPTIONAL, INTENT(INOUT) :: qnn,nwfa, nifa + REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL, INTENT(INOUT) :: nwfa2d,qnn2d + REAL, OPTIONAL, INTENT(IN) :: DX, DY, cccn + LOGICAL, OPTIONAL, INTENT(IN) :: is_start + CHARACTER*256:: mp_debug + + + INTEGER:: i, j, k, l, m, n + REAL:: h_01, niIN3, niCCN3, max_test + + REAL, PARAMETER :: eps = 1.E-15 +! LOGICAL:: has_CCN, has_IN + + is_aerosol_aware = .FALSE. +! micro_init = .FALSE. +! has_CCN = .FALSE. +! has_IN = .FALSE. + + + write(mp_debug,*) ' DEBUG checking column of hgt ', its+1,jts+1 + CALL wrf_debug(250, mp_debug) + do k = kts, kte + write(mp_debug,*) ' DEBUGT k, hgt = ', k, hgt(its+1,k,jts+1) + CALL wrf_debug(250, mp_debug) + enddo + + if (PRESENT(qnn2d) .AND. PRESENT(qnn) .AND. PRESENT(nifa)) is_aerosol_aware = .TRUE. + + if (is_aerosol_aware) then + + turn_on_cin = .true. + +!..Check for existing aerosol data, both CCN and IN aerosols. If missing +!.. fill in just a basic vertical profile, somewhat boundary-layer following. + + max_test = MAXVAL ( qnn(its:ite-1,:,jts:jte-1) ) + + if (max_test .lt. eps) then + write(mp_debug,*) ' Apparently there are no initial CCN aerosols, so we will initialize using nssl_cccn value.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' checked column at point (i,j) = ', its,jts + CALL wrf_debug(100, mp_debug) + do j = jts, min(jde-1,jte) + do i = its, min(ide-1,ite) + do k = 1, kte + qnn(i,k,j) = cccn/1.225 ! naCCN1+naCCN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niCCN3) + enddo + enddo + enddo + else +! has_CCN = .TRUE. + write(mp_debug,*) ' Apparently initial CCN aerosols are present.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' column sum at point (i,j) = ', its,jts, SUM(qnn(its,:,jts)) + CALL wrf_debug(100, mp_debug) + endif + + + max_test = MAXVAL ( nifa(its:ite-1,:,jts:jte-1) ) + + if (max_test .lt. eps) then + write(mp_debug,*) ' Apparently there are no initial IN aerosols.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' checked column at point (i,j) = ', its,jts + CALL wrf_debug(100, mp_debug) + do j = jts, min(jde-1,jte) + do i = its, min(ide-1,ite) + if (hgt(i,1,j).le.1000.0) then + h_01 = 0.8 + elseif (hgt(i,1,j).ge.2500.0) then + h_01 = 0.01 + else + h_01 = 0.8*cos(hgt(i,1,j)*0.001 - 1.0) + endif + niIN3 = -1.0*ALOG(naIN1/naIN0)/h_01 + nifa(i,1,j) = naIN1+naIN0*exp(-((hgt(i,2,j)-hgt(i,1,j))/1000.)*niIN3) + do k = 2, kte + nifa(i,k,j) = naIN1+naIN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niIN3) + enddo + enddo + enddo + else +! has_IN = .TRUE. + write(mp_debug,*) ' Apparently initial IN aerosols are present.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' column sum at point (i,j) = ', its,jts, SUM(nifa(its,:,jts)) + CALL wrf_debug(100, mp_debug) + endif + +!..Capture initial state lowest level CCN aerosol data in 2D array. + +! do j = jts, min(jde-1,jte) +! do i = its, min(ide-1,ite) +! qnn2d(i,j) = qnn(i,kts,j) +! enddo +! enddo + +!..Scale the lowest level aerosol data into an emissions rate. This is +!.. very far from ideal, but need higher emissions where larger amount +!.. of existing and lesser emissions where not already lots of aerosols +!.. for first-order simplistic approach. Later, proper connection to +!.. emission inventory would be better, but, for now, scale like this: +!.. where: Nwfa=50 per cc, emit 0.875E4 aerosols per kg per second +!.. Nwfa=500 per cc, emit 0.875E5 aerosols per kg per second +!.. Nwfa=5000 per cc, emit 0.875E6 aerosols per kg per second +!.. for a grid with 20km spacing and scale accordingly for other spacings. + + if (is_start) then + if (SQRT(DX*DY)/20000.0 .ge. 1.0) then + h_01 = 0.875 + else + h_01 = (0.875 + 0.125*((20000.-SQRT(DX*DY))/16000.)) * SQRT(DX*DY)/20000. + endif + write(mp_debug,*) ' aerosol surface flux emission scale factor is: ', h_01 + CALL wrf_debug(100, mp_debug) + do j = jts, min(jde-1,jte) + do i = its, min(ide-1,ite) + ! qnn2d(i,j) = 10.0**(LOG10(qnn(i,kts,j)*1.E-6)-3.69897) + ! qnn2d(i,j) = qnn2d(i,j)*h_01 * 1.E6 + qnn2d(i,j) = (qnn(i,kts,j))/5000. ! same as above -- scale to 5000s for full restore + qnn2d(i,j) = qnn2d(i,j)*h_01 + + nwfa2d(i,j) = 10.0**(LOG10(nwfa(i,kts,j)*1.E-6)-3.69897) + nwfa2d(i,j) = nwfa2d(i,j)*h_01 * 1.E6 + + enddo + enddo +! else +! write(mp_debug,*) ' sample (lower-left) aerosol surface flux emission rate: ', qnn2d(1,1) +! CALL wrf_debug(100, mp_debug) + endif + + endif + + + + RETURN +END SUBROUTINE nssl_2mom_init_aero + +! ##################################################################### +! ##################################################################### + + + SUBROUTINE nssl_2mom_init( & + & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & + & nssl_graupelfallfac, & + & nssl_hailfallfac, & + & nssl_ehw0, & + & nssl_ehlw0, & + & nssl_icdx, & + & nssl_icdxhl, & + & nssl_icefallfac, & + & nssl_snowfallfac & + ) + + + implicit none + + real, intent(in), optional :: & + & nssl_graupelfallfac, & + & nssl_hailfallfac, & + & nssl_ehw0, & + & nssl_ehlw0, & + & nssl_icefallfac, & + & nssl_snowfallfac + integer, intent(in), optional :: & + & nssl_icdx, & + & nssl_icdxhl + + integer, intent(in) :: ims,ime, jms,jme, kms,kme + real, intent(in), dimension(20) :: nssl_params + + + + integer, intent(in) :: ipctmp,mixphase,ihvol + logical, optional, intent(in) :: idoniconlytmp + double precision :: arg + real :: temq + integer :: igam + integer :: i,il,j,l + integer :: ltmp + integer :: isub + real :: bxh,bxhl + + real :: alp,ratio + double precision :: x,y,y2,y7 + logical :: turn_on_ccna + integer :: istat + + + turn_on_ccna = .false. +! turn_on_cin = .false. +! +! set some global values from namelist input +! + + ccn = Abs( nssl_params(1) ) + alphah = nssl_params(2) + alphahl = nssl_params(3) + cnoh = nssl_params(4) + cnohl = nssl_params(5) + cnor = nssl_params(6) + cnos = nssl_params(7) + rho_qh = nssl_params(8) + rho_qhl = nssl_params(9) + rho_qs = nssl_params(10) + +! ipelec = Nint(nssl_params(11)) +! isaund = Nint(nssl_params(12)) + IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac + IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac + IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0 + IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0 + IF ( present(nssl_icdx) ) icdx = nssl_icdx + IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl + IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac + IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac + + + IF ( Nint(nssl_params(13)) == 1 ) THEN + ! hack to switch CCN field to CCNA (activated ccn) +! invertccn = .true. + turn_on_ccna = .true. + irenuc = 7 + ENDIF + + + + + + + + IF ( irenuc >= 5 ) THEN + turn_on_ccna = .true. + ENDIF + + cwccn = ccn + + lhab = 8 + lhl = 8 + IF ( icespheres >= 1 ) THEN + lhab = lhab + 1 + lis = li + 1 + ls = ls + 1 + lh = lh + 1 + lhl = lhl + 1 + ENDIF + IF ( ihvol <= -1 .or. ihvol == 2 ) THEN + IF ( ihvol == -1 .or. ihvol == -2 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + ! past me thought it would be a good idea to change graupel factors when hail is off.... + ! ehw0 = 0.75 + ! iehw = 2 + ! dfrz = Max( dfrz, 0.5e-3 ) + ENDIF + IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off + ! a value of -3 means to turn off ice crystals but turn on hail + renucfrac = 1.0 + ffrzs = 1.0 + ! idoci = 0 ! try this later + ENDIF + ENDIF + +! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl + +! IF ( ipelec > 0 ) idonic = .true. + +! +! Build lookup table for saturation mixing ratio (Soong and Ogura 73) +! + + do l = 1,nqsat + temq = 163.15 + (l-1)*fqsat + IF ( iqvsopt == 0 ) THEN + tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) + dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + & + & caw/(temq - cbw))*tabqvs(l) + ELSE + tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) + dtabqvs(l) = ((-cawbolton*(-273.15 + temq))/(temq - cbwbolton)**2 + & + & cawbolton/(temq - cbwbolton))*tabqvs(l) + ENDIF + tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) + dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + & + & cai/(temq - cbi))*tabqis(l) + end do + + bx(lr) = 0.85 + ax(lr) = 1647.81 + fx(lr) = 135.477 + + IF ( icdx == 6 ) THEN + bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550. + ax(lh) = 157.71 + ELSEIF ( icdx > 0 ) THEN + bx(lh) = 0.5 + ax(lh) = 75.7149 + ELSE + bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 + ax(lh) = 19.3 + ENDIF +! bx(lh) = 0.6 + + IF ( lhl .gt. 1 ) THEN + IF ( icdxhl == 6 ) THEN + bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750. + ax(lhl) = 179.36 + ELSEIF (icdxhl > 0 ) THEN + bx(lhl) = 0.5 + ax(lhl) = 75.7149 + ELSE + ax(lhl) = 206.984 ! Ferrier 1994 + bx(lhl) = 0.6384 + ENDIF + ENDIF + +! fill in the complete gamma function lookup table + gmoi(0) = 1.d32 + do igam = 1,ngm0 + arg = dgam*igam + gmoi(igam) = gamma_dp(arg) + end do + + ! build lookup table to compute the number and mass fractions of rain drops + ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr + ! Uses incomplete gamma functions + ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) + + bxh = bx(lh) + bxhl = bx(Max(lh,lhl)) + +! DO j = 0,nqiacralpha + DO j = ialpstart,nqiacralpha + alp = float(j)*dqiacralpha + y = gamma_dpr(1.+alp) + y2 = gamma_dpr(2.+alp) + DO i = 0,nqiacrratio + ratio = float(i)*dqiacrratio + x = gamxinfdp( 1.+alp, ratio ) +! write(0,*) 'i, x/y = ',i, x/y + ciacrratio(i,j) = x/y + + ! graupel (.,.,.,1) + gamxinflu(i,j,1,1) = x/y + gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y + gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y + gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y + gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y + gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y + gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y + + gamxinflu(i,j,12,1) = gamxinfdp( 2.0+alp, ratio )/y2 + + ! hail (.,.,.,2) + gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) + gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) + gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y + gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1) + gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y + gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1) + gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1) + + IF ( alp > 1.1 ) THEN +! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y + gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y +! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y +! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y + ELSE +! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y + gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y +! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y +! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y + gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y + ENDIF + + gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) + + ENDDO + ENDDO + ciacrratio(0,:) = 1.0 + + DO j = ialpstart,nqiacralpha + alp = float(j)*dqiacralpha + y = gamma_sp(4.+alp) + y7 = gamma_sp(7.+alp) + DO i = 0,nqiacrratio + ratio = float(i)*dqiacrratio + + ! mass fraction + x = gamxinfdp( 4.+alp, ratio ) +! write(0,*) 'i, x/y = ',i, x/y + qiacrratio(i,j) = x/y + gamxinflu(i,j,4,1) = x/y + gamxinflu(i,j,4,2) = x/y + + ! reflectivity fraction + x = gamxinfdp( 7.+alp, ratio ) + ziacrratio(i,j) = x/y7 + gamxinflu(i,j,11,1) = x/y7 + gamxinflu(i,j,11,2) = x/y7 + + ENDDO + ENDDO + qiacrratio(0,:) = 1.0 + + + isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0 + + lccn = 0 + lccna = 0 + lnc = 0 + lnr = 0 + lni = 0 + lnis = 0 + lns = 0 + lnh = 0 + lnhl = 0 + lvh = 0 + lvhl = 0 + lzr = 0 + lzh = 0 + lzhl = 0 + lsw = 0 + lhw = 0 + lhlw = 0 + + denscale(:) = 0 + +! lccn = 9 + + ipconc = ipctmp + + IF ( ipconc == 0 ) THEN + IF ( ihvol >= 0 ) THEN + lvh = 9 + ltmp = 9 + denscale(lvh) = 1 + ELSE ! no hail + ltmp = lhab + lhl = 0 + ENDIF + ELSEIF ( ipconc == 5 ) THEN + lccn = lhab+1 ! 9 + lnc = lhab+2 ! 10 + lnr = lhab+3 ! 11 + lni = lhab+4 !12 + lns = lhab+5 !13 + lnh = lhab+6 !14 + ltmp = lnh + IF ( ihvol >= 0 ) THEN + ltmp = ltmp + 1 + lnhl = ltmp ! lhab+7 ! 15 + ENDIF + ltmp = ltmp + 1 + lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off +! ltmp = lvh + denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + ltmp = ltmp + 1 + lvhl = ltmp +! ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + IF ( mixedphase ) THEN + ltmp = ltmp + 1 + lsw = ltmp + ltmp = ltmp + 1 + lhw = ltmp + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lhlw = ltmp + ENDIF +! ltmp = lhlw + ENDIF + ELSEIF ( ipconc >= 6 ) THEN + write(0,*) 'NSSL microphysics has not been compiled for 3-moment. Sorry.' + STOP + lccn = lhab+1 ! 9 + lnc = lhab+2 ! 10 + lnr = lhab+3 ! 11 + lni = lhab+4 !12 + lns = lhab+5 !13 + lnh = lhab+6 !14 + ltmp = lnh + IF ( lhl > 0 ) THEN + ltmp = ltmp + 1 + lnhl = ltmp ! lhab+7 ! 15 + ENDIF + ltmp = ltmp + 1 + lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off +! ltmp = lvh + denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + ltmp = ltmp + 1 + lvhl = ltmp +! ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + + IF ( ipconc == 6 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ELSEIF ( ipconc == 7 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ltmp = ltmp + 1 + lzr = ltmp + ELSEIF ( ipconc == 8 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ltmp = ltmp + 1 + lzr = ltmp + ltmp = ltmp + 1 + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lzhl = ltmp + ENDIF + ENDIF +! ltmp = lvh + ! denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + lvhl = ltmp+1 + ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + IF ( mixedphase ) THEN + ltmp = ltmp + 1 + lsw = ltmp + ltmp = ltmp + 1 + lhw = ltmp + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lhlw = ltmp + ENDIF +! ltmp = lhlw + ENDIF + ELSE + CALL wrf_error_fatal( 'nssl_2mom_init: Invalid value of ipctmp' ) + ENDIF + + + + + ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna + IF ( turn_on_ccna ) THEN + ltmp = ltmp + 1 + lccna = ltmp + denscale(ltmp) = 1 + ENDIF + + IF ( turn_on_cin .or. is_aerosol_aware ) THEN + ltmp = ltmp + 1 + lcin = ltmp + denscale(ltmp) = 1 +!debug write(0,*) 'Setting lcin to ',lcin + ENDIF + na = ltmp + + ln(lc) = lnc + ln(lr) = lnr + ln(li) = lni + ln(ls) = lns + ln(lh) = lnh + IF ( lhl .gt. 1 ) ln(lhl) = lnhl + + ipc(lc) = 2 + ipc(lr) = 3 + ipc(li) = 1 + ipc(ls) = 4 + ipc(lh) = 5 + IF ( lhl .gt. 1 ) ipc(lhl) = 5 + + ldovol = .false. + lvol(:) = 0 + lvol(li) = lvi + lvol(ls) = lvs + lvol(lh) = lvh + IF ( lhl .gt. 1 .and. lvhl .gt. 1 ) lvol(lhl) = lvhl + + lne = Max(lnh,lnhl) + lne = Max(lne,lvh) + lne = Max(lne,lvhl) + lne = Max(lne,na) + + lsc(:) = 0 + lsc(lc) = lscw + lsc(lr) = lscr + lsc(li) = lsci + lsc(ls) = lscs + lsc(lh) = lsch + IF ( lhl .gt. 1 ) lsc(lhl) = lschl + + + DO il = lc,lhab + ldovol = ldovol .or. ( lvol(il) .gt. 1 ) + ENDDO + +! write(0,*) 'nssl_2mom_init: ldovol = ',ldovol + + lz(:) = 0 + lz(lr) = lzr + lz(li) = lzi + lz(ls) = lzs + lz(lh) = lzh + IF ( lhl .gt. 1 .and. lzhl > 1 ) lz(lhl) = lzhl + + lliq(:) = 0 + lliq(ls) = lsw + lliq(lh) = lhw + IF ( lhl .gt. 1 ) lliq(lhl) = lhlw + IF ( mixedphase ) THEN +! write(0,*) 'lsw,lhw,lhlw = ',lsw,lhw,lhlw + ENDIF + + + + xnu(lc) = cnu + xmu(lc) = 1. + + IF ( imurain == 3 ) THEN + xnu(lr) = rnu + xmu(lr) = 1. + ELSEIF ( imurain == 1 ) THEN + xnu(lr) = (alphar - 2.0)/3.0 + xmu(lr) = 1./3. + ENDIF + + xnu(li) = cinu + xmu(li) = 1. + + IF ( lis >= 1 ) THEN + xnu(lis) = 0.0 + xmu(lis) = 1. + ENDIF + + dnu(lc) = 3.*xnu(lc) + 2. ! alphac + dmu(lc) = 3.*xmu(lc) + + dnu(lr) = 3.*xnu(lr) + 2. ! alphar + dmu(lr) = 3.*xmu(lr) + + xnu(ls) = snu + xmu(ls) = 1. + + dnu(ls) = 3.*xnu(ls) + 2. ! -0.4 ! alphas + dmu(ls) = 3.*xmu(ls) + + + dnu(lh) = alphah + dmu(lh) = dmuh + + xnu(lh) = (dnu(lh) - 2.)/3. + xmu(lh) = dmuh/3. + + + IF ( imurain == 3 ) THEN ! rain is gamma of volume + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ & + & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr))) + +! IF ( ipconc .lt. 5 ) alphahl = alphah + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + xnu(lr)))/ & + & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(2. + xnu(lr))) + + rzs = 1. ! assume rain and snow are both gamma volume + + ELSE ! rain is gamma of diameter + + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + + rzs = & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)*(2. + xnu(ls)))/ & + & ((4. + alphar)*(5. + alphar)*(6. + alphar)*(1. + xnu(ls))) + + + ENDIF + + IF ( ipconc <= 5 ) THEN + imltshddmr = Min(1, imltshddmr) + ibinhmlr = 0 + ibinhlmlr = 0 + ENDIF + + IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN + imltshddmr = Min(1, imltshddmr) + ENDIF + +! write(0,*) 'rz,rzhl = ', rz,rzhl + + IF ( ipconc .lt. 4 ) THEN + + dnu(ls) = alphas + dmu(ls) = 1. + + xnu(ls) = (dnu(ls) - 2.)/3. + xmu(ls) = 1./3. + + + ENDIF + + IF ( lhl .gt. 1 ) THEN + + dnu(lhl) = alphahl + dmu(lhl) = dmuhl + + xnu(lhl) = (dnu(lhl) - 2.)/3. + xmu(lhl) = dmuhl/3. + + ENDIF + + cno(lc) = 1.0e+08 + IF ( li .gt. 1 ) cno(li) = 1.0e+08 + cno(lr) = cnor + IF ( ls .gt. 1 ) cno(ls) = cnos ! 8.0e+06 + IF ( lh .gt. 1 ) cno(lh) = cnoh ! 4.0e+05 + IF ( lhl .gt. 1 ) cno(lhl) = cnohl ! 4.0e+05 +! +! density maximums and minimums +! + xdnmx(:) = 900.0 + + xdnmx(lr) = 1000.0 + xdnmx(lc) = 1000.0 + xdnmx(li) = 917.0 + xdnmx(ls) = 300.0 + xdnmx(lh) = 900.0 + IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 +! + xdnmn(:) = 900.0 + + xdnmn(lr) = 1000.0 + xdnmn(lc) = 1000.0 + xdnmn(li) = 100.0 + xdnmn(ls) = 100.0 + xdnmn(lh) = hdnmn + IF ( lhl .gt. 1 ) xdnmn(lhl) = hldnmn + + xdn0(:) = 900.0 + + xdn0(lc) = 1000.0 + xdn0(li) = 900.0 + xdn0(lr) = 1000.0 + xdn0(ls) = rho_qs ! 100.0 + xdn0(lh) = rho_qh ! (0.5)*(xdnmn(lh)+xdnmx(lh)) + IF ( lhl .gt. 1 ) xdn0(lhl) = rho_qhl ! 800.0 + +! +! Set terminal velocities... +! also set drag coefficients +! + cdx(lr) = 0.60 + cdx(lh) = 0.8 ! 1.0 ! 0.45 + cdx(ls) = 2.00 + IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 + + ido(lc) = idocw + ido(lr) = idorw + ido(li) = idoci + ido(ls) = idosw + ido(lh) = idohw + IF ( lhl .gt. 1 ) ido(lhl) = idohl + + IF ( irfall .lt. 0 ) irfall = infall + IF ( lzr > 0 ) irfall = 0 + + qccn = ccn/rho00 +! xvcmx = (4./3.)*pi*xcradmx**3 + +! set max rain diameter + IF ( xvdmx .gt. 0.0 ) THEN + xvrmx = 0.523599*(xvdmx)**3 + ELSE + xvrmx = xvrmx0 + ENDIF + + IF ( dhmn <= 0.0 ) THEN + xvhmn = xvhmn0 +! xvhmn = Min(xvhmn0, 0.523599*(dfrz)**3 ) + ELSE + xvhmn = 0.523599*(dhmn)**3 +! xvhmn = 0.523599*(Min(dhmn,dfrz))**3 + ENDIF + + IF ( dhmx <= 0.0 ) THEN + xvhmx = xvhmx0 + ELSE + xvhmx = 0.523599*(dhmx)**3 + ENDIF + + IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh) + IF ( qhacidn < 0. ) qhacidn = xdnmn(lh) + +! load max/min diameters + xvmn(lc) = xvcmn + xvmn(li) = xvimn + xvmn(lr) = xvrmn + xvmn(ls) = xvsmn + xvmn(lh) = xvhmn + + xvmx(lc) = xvcmx + xvmx(li) = xvimx + xvmx(lr) = xvrmx + xvmx(ls) = xvsmx + xvmx(lh) = xvhmx + + IF ( lhl .gt. 1 ) THEN + xvmn(lhl) = xvhlmn + xvmx(lhl) = xvhlmx + ENDIF + +! +! cloud water constants in mks units +! +! cwmasn = 4.25e-15 ! radius of 1.0e-6 +! cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 +! cwmasn5 = 5.23e-13 +! cwradn = 5.0e-6 ! minimum radius +! cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 +! mwfac = 6.0**(1./3.) + IF ( ipconc .ge. 2 ) THEN +! cwmasn = xvmn(lc)*1000. ! minimum mass, defined by minimum droplet volume +! cwradn = 1.0e-6 ! minimum radius +! cwmasx = xvmx(lc)*1000. ! maximum mass, defined by maximum droplet volume + + ENDIF +! rwmasn = xvmn(lr)*1000. ! minimum mass, defined by minimum rain volume +! rwmasx = xvmx(lr)*1000. ! maximum mass, defined by maximum rain volume + + IF ( lhl < 1 ) ifrzg = 1 + + ventr = 1. + IF ( imurain == 3 ) THEN +! IF ( izwisventr == 1 ) THEN + ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985 +! ELSE + ventrn = Gamma_sp(rnu + 1.5 + br/6.)/(Gamma_sp(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ! adapted from Wisner et al. 1972; for second term in rwvent +! ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985, still use for first term in rwvent +! ventr = Gamma_sp(rnu + 4./3.)/Gamma_sp(rnu + 1.) +! ENDIF + ELSE ! imurain == 1 +! IF ( iferwisventr == 1 ) THEN + ventr = Gamma_sp(2. + alphar) ! Ferrier 1994 +! ELSEIF ( iferwisventr == 2 ) THEN + ventrn = Gamma_sp(alphar + 2.5 + br/2.)/Gamma_sp(alphar + 1.) ! adapted from Wisner et al. 1972 +! ENDIF + ENDIF + ventc = Gamma_sp(cnu + 4./3.)/(cnu + 1.)**(1./3.)/Gamma_sp(cnu + 1.) + c1sw = Gamma_sp(snu + 4./3.)*(snu + 1.0)**(-1./3.)/gamma_sp(snu + 1.0) + + ! set threshold mixing ratios + + qxmin(:) = 1.0e-12 + + qxmin(lc) = 1.e-9 + qxmin(lr) = 1.e-7 + IF ( li > 1 ) qxmin(li) = 1.e-12 + IF ( ls > 1 ) qxmin(ls) = 1.e-7 + IF ( lh > 1 ) qxmin(lh) = 1.e-7 + IF ( lhl .gt. 1 ) qxmin(lhl) = 1.e-7 + + IF ( lc .gt. 1 .and. lnc .gt. 1 ) qxmin(lc) = 1.0e-13 + IF ( lr .gt. 1 .and. lnr .gt. 1 ) qxmin(lr) = 1.0e-12 + + IF ( li .gt. 1 .and. lni .gt. 1 ) qxmin(li ) = 1.0e-13 + IF ( ls .gt. 1 .and. lns .gt. 1 ) qxmin(ls ) = 1.0e-13 + IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12 + IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12 + + ! constants for droplet nucleation + + cckm = cck-1. + ccnefac = (1.63/(cck * beta(3./2., cck/2.)))**(cck/(cck + 2.0)) + cnexp = (3./2.)*cck/(cck+2.0) +! ccne is all the factors with w in eq. A7 in Mansell et al. 2010 (JAS). The constant changes +! if k (cck) is changed! + ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) + ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck)) +! write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp + IF ( cwccn .lt. 0.0 ) THEN + cwccn = Abs(cwccn) + ccwmx = 50.e9 ! cwccn + ELSE + ccwmx = 50.e9 ! cwccn ! *1.4 + ENDIF + +! +! +! Set collection coefficients (Seifert and Beheng 05) +! + bb(:) = 1.0/3.0 + bb(li) = 0.3429 + DO il = lc,lhab + da0(il) = delbk(bb(il), xnu(il), xmu(il), 0) + da1(il) = delbk(bb(il), xnu(il), xmu(il), 1) + +! write(0,*) 'il, da0, da1, xnu, xmu = ', il, da0(il), da1(il), xnu(il), xmu(il) + ENDDO + + dab0(:,:) = 0.0 + dab1(:,:) = 0.0 + + DO il = lc,lhab + DO j = lc,lhab + IF ( il .ne. j ) THEN + + dab0(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 0) + dab1(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 1) + +! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j) + ENDIF + ENDDO + ENDDO + + gf4br = gamma_sp(4.0+br) + gf4ds = gamma_sp(4.0+ds) + gf4p5 = gamma_sp(4.0+0.5) + gfcinu1 = gamma_sp(cinu + 1.0) + gfcinu1p47 = gamma_sp(cinu + 1.47167) + gfcinu2p47 = gamma_sp(cinu + 2.47167) + gfcinu1p22 = gamma_sp(cinu + 1.22117) + gfcinu2p22 = gamma_sp(cinu + 2.22117) + gfcinu1p18 = gamma_sp(cinu + 1.18333) + gfcinu2p18 = gamma_sp(cinu + 2.18333) + + gsnow1 = gamma_sp(snu + 1.0) + gsnow53 = gamma_sp(snu + 5./3.) + gsnow73 = gamma_sp(snu + 7./3.) + + IF ( lh .gt. 1 ) cwchtmp0 = 6.0/pi*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) + IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) + + + iexy(:,:)=0; ! sets to zero the ones Imight have forgotten + +! snow + iexy(ls,li) = ieswi + iexy(ls,lc) = ieswc ; iexy(ls,lr) = ieswr ; + +! graupel + iexy(lh,ls) = iehwsw ; iexy(lh,li) = iehwi ; + iexy(lh,lc) = iehwc ; iexy(lh,lr) = iehwr ; + +! hail + IF (lhl .gt. 1 ) THEN + iexy(lhl,ls) = iehlsw ; iexy(lhl,li) = iehli ; + iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; + ENDIF + + IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac + IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac + + + RETURN +END SUBROUTINE nssl_2mom_init + +! ##################################################################### +! ##################################################################### + +SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & + cn, vhw, vhl, cna, f_cn, f_cna, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + tt, th, pii, p, w, dn, dz, dtp, itimestep, & + RAINNC,RAINNCV, & + dx, dy, & + axtra, & + SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & + SR,HAILNC, HAILNCV, & + tkediss, & + re_cloud, re_ice, re_snow, & + has_reqc, has_reqi, has_reqs, & + rainncw2, rainnci2, & + dbz, vzf,compdbz, & + rscghis_2d,rscghis_2dp,rscghis_2dn, & + scr,scw,sci,scs,sch,schl,sctot, & + induc,elec,scion,sciona, & + noninduc,noninducp,noninducn, & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2, & +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & + ipelectmp, & + diagflag,ke_diag, & + NWFA, f_qnwfa, & + NIFA, f_qnifa, & + nwfa2d, & + qnn2d, & + nssl_progn, & ! wrf-chem +! 20130903 acd_mb_washout start + rainprod, evapprod, & ! wrf-chem +! 20130903 acd_mb_washout end + cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte) ! tile dims + + + +#if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) +#define MPI + USE module_dm, ONLY : & + local_communicator, mytask +! keep a spacing line here to keep Apple cpp from adding a space in front of the endif +#endif + + implicit none + +#if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) || defined(MPI) + INCLUDE 'mpif.h' +#else + integer :: mytask = 0 + +#endif + + !Subroutine arguments: + + integer, intent(in):: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + qv,qc,qr,qs,qh + ! tt is air temperature -- used by CCPP instead of th (theta) + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + th, tt, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna + real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz + real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate + rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) + rscghis_2dn ! 2D accumulation arrays for vertically-integrated charging rate (negative only) +! real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elec ! elecsave = Ez + real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn + + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2 +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail + + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra + +! WRF variables + real, dimension(ims:ime, jms:jme), intent(inout):: & + RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout):: & + SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout):: & + HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: & + re_cloud, re_ice, re_snow, nwfa, nifa + real, dimension(ims:ime, jms:jme), intent(in), optional :: nwfa2d,qnn2d + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs + real, dimension(ims:ime, jms:jme), intent(out), optional :: & + rainncw2, rainnci2 ! liquid rain, ice, accumulation rates + real, optional, intent(in) :: dx,dy + real, intent(in):: dtp + integer, intent(in):: itimestep !, ccntype + logical, optional, intent(in) :: diagflag, f_cna, f_cn + integer, optional, intent(in) :: ipelectmp, ke_diag + + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem + LOGICAL, INTENT(IN), OPTIONAL :: f_qnifa , f_qnwfa ! flags for Thompson aero + +! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop + LOGICAL :: flag_qndrop ! wrf-chem + LOGICAL :: flag_qnifa , flag_qnwfa + real :: cinchange, t7max,testmax,wmax + +! 20130903 acd_ck_washout start +! rainprod - total tendency of conversion of cloud water/ice and graupel to rain (kg kg-1 s-1) +! evapprod - tendency of evaporation of rain (kg kg-1 s-1) +! 20130903 acd_ck_washout end + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: rainprod, evapprod + +! qrcuten, rain tendency from parameterized cumulus convection +! qscuten, snow tendency from parameterized cumulus convection +! qicuten, cloud ice tendency from parameterized cumulus convection +! mu : air mass in column + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: qrcuten, qscuten, qicuten, qccuten + INTEGER, optional, intent(in) :: cu_used + +! +! local variables +! + real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab +! real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+ + real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d + real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten + real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d + real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 + real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d + real, dimension(its:ite, 1, na) :: xfall + integer, parameter :: nor = 0, ng = 0 + integer :: nx,ny,nz + integer ix,jy,kz,i,j,k,il,n + integer :: infdo + real :: ssival, ssifac, t8s, t9s, qvapor + integer :: ltemq + double precision :: dp1 + integer :: jye, lnb + integer :: imx,kmx + real :: dbzmx,refl + integer :: vzflag0 = 0 + logical :: makediag + real, parameter :: cnin20 = 1.0e3 + real, parameter :: cnin10 = 5.0e1 + real, parameter :: cnin1a = 4.5 + real, parameter :: cnin2a = 12.96 + real, parameter :: cnin2b = 0.639 + + double precision :: cwmass1,cwmass2 + double precision :: rwmass1,rwmass2 + double precision :: icemass1,icemass2 + double precision :: swmass1,swmass2 + double precision :: grmass1,grmass2 + double precision :: hlmass1,hlmass2 + double precision :: wvol5,wvol10 + real :: tmp,dv,dv1 + real :: rdt + + double precision :: dt1,dt2 + double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed + double precision :: timevtcalc,timesetvt + + logical :: f_cnatmp + + integer :: kediagloc + integer :: iunit + +#ifdef MPI + +#if defined(MPI) + integer, parameter :: ntot = 50 + double precision mpitotindp(ntot), mpitotoutdp(ntot) + INTEGER :: mpi_error_code = 1 +#endif +#endif + + +! ------------------------------------------------------------------- + + + rdt = 1.0/dtp + +! write(0,*) 'N2M: entering routine' + + flag_qndrop = .false. + flag_qnifa = .false. + flag_qnwfa = .false. + + IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn + + IF ( PRESENT ( f_qnifa ) ) flag_qnifa = f_qnifa + IF ( PRESENT ( f_qnwfa ) ) flag_qnwfa = f_qnwfa + + + + ! --- + + IF ( present( f_cna ) ) THEN + f_cnatmp = f_cna + ELSE + f_cnatmp = .false. + ENDIF + + IF ( present( vzf ) ) vzflag0 = 1 + + IF ( present( ipelectmp ) ) THEN + ipelec = ipelectmp + ELSE + ipelec = 0 + ENDIF +! IF ( present( dbz ) ) THEN +! DO jy = jts,jte +! DO kz = kts,kte +! DO ix = its,ite +! dbz(ix,kz,jy) = 0.0 +! ENDDO +! ENDDO +! ENDDO +! ENDIF + + + makediag = .true. + IF ( present( diagflag ) ) THEN + makediag = diagflag .or. itimestep == 1 + ENDIF + +! write(0,*) 'N2M: makediag = ',makediag + + + nx = ite-its+1 + ny = 1 ! set up as 2D slabs + nz = kte-kts+1 + + IF ( .not. present( cn ) ) THEN + renucfrac = 1.0 + ENDIF + +! set up CCN array and some other static local values + IF ( .false. ) THEN + IF ( itimestep == 1 .and. .not. invertccn .and. present( cn ) ) THEN + ! this is not needed for WRF 3.8 and later because it is done in physics_init, + ! but kept for backwards compatibility with earlier versions + IF ( cn((ite+its)/2,(kte+kts)/2,(jte+jts)/2) < 10.0 ) THEN ! initialize ccn if not already done + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cn(ix,kz,jy) = qccn + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + IF ( itimestep == 1 .and. invertccn .and. present( cn ) ) THEN + ! this is not needed for WRF 3.8 and later because it is done in physics_init, + ! but kept for backwards compatibility with earlier versions + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cn(ix,kz,jy) = 0.0 + ENDDO + ENDDO + ENDDO + ENDIF + + IF ( invertccn .and. present( cn ) ) THEN ! hack for WRF to convert activated ccn to unactivated, then do not have to + ! worry about initial and boundary conditions - they are zero + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + ! cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + +! ENDIF ! itimestep == 1 + +! sedimentation settings + + infdo = 2 + + IF ( infall .ne. 1 .or. iscfall .ge. 2 ) THEN + infdo = 1 + ELSE + infdo = 0 + ENDIF + + IF ( infall .ge. 3 .or. ipconc .ge. 6 ) THEN + infdo = 2 + ENDIF + + + IF ( present( HAILNCV ) .and. lhl < 1 ) THEN ! for WRF 3.1 compatibility + HAILNCV(its:ite,jts:jte) = 0. + ENDIF + + tke2d(:,:) = 0.0 ! initialize if not used + + lnb = Max(lh,lhl)+1 ! lnc +! IF ( lccn > 1 ) lnb = lccn + + jye = jte + + IF ( present( compdbz ) .and. makediag ) THEN + DO jy = jts,jye + DO ix = its,ite + compdbz(ix,jy) = -3.0 + ENDDO + ENDDO + ENDIF + + zmaxsed = 0.0d0 + timevtcalc = 0.0d0 + timesetvt = 0.0d0 + timesed = 0.0d0 + timesed1 = 0.0d0 + timesed2 = 0.0d0 + timesed3 = 0.0d0 + timegs = 0.0d0 + timenucond = 0.0d0 + + + +! write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) + + ancuten(its:ite,1,kts:kte,:) = 0.0 + + DO jy = jts,jye + + xfall(:,:,:) = 0.0 + +! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn + + IF ( present( pcc2 ) .and. makediag ) THEN + axtra2d(its:ite,1,kts:kte,:) = 0.0 + ENDIF + + ! copy from 3D array to 2D slab + + DO kz = kts,kte + DO ix = its,ite + + IF ( present( tt ) ) THEN + an(ix,1,kz,lt) = tt(ix,kz,jy)/pii(ix,kz,jy) + ELSE + an(ix,1,kz,lt) = th(ix,kz,jy) + ENDIF + + + an(ix,1,kz,lv) = qv(ix,kz,jy) + an(ix,1,kz,lc) = qc(ix,kz,jy) + an(ix,1,kz,lr) = qr(ix,kz,jy) + IF ( present( qi ) ) THEN + an(ix,1,kz,li) = qi(ix,kz,jy) + ELSE + an(ix,1,kz,li) = 0.0 + ENDIF + an(ix,1,kz,ls) = qs(ix,kz,jy) + an(ix,1,kz,lh) = qh(ix,kz,jy) + IF ( lhl > 1 ) an(ix,1,kz,lhl) = qhl(ix,kz,jy) + IF ( lccn > 1 ) THEN + IF ( is_aerosol_aware .and. flag_qnwfa ) THEN + an(ix,1,kz,lccn) = nwfa(ix,kz,jy) + ELSEIF ( present( cn ) ) THEN + IF ( invertccn ) THEN + an(ix,1,kz,lccn) = qccn - cn(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = cn(ix,kz,jy) + ENDIF + ELSE + IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN + an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = qccn + ENDIF + + ENDIF + ENDIF + + IF ( lccna > 1 ) THEN + IF ( present( cna ) .and. f_cnatmp ) THEN + an(ix,1,kz,lccna) = cna(ix,kz,jy) + ENDIF + ENDIF + + IF ( lcin > 1 .and. flag_qnifa ) THEN + an(ix,1,kz,lcin) = nifa(ix,kz,jy) + ENDIF + + IF ( ipconc >= 5 ) THEN + an(ix,1,kz,lnc) = ccw(ix,kz,jy) + IF ( constccw > 0.0 ) THEN + an(ix,1,kz,lnc) = constccw + ENDIF + an(ix,1,kz,lnr) = crw(ix,kz,jy) + IF ( present( cci ) ) THEN + an(ix,1,kz,lni) = cci(ix,kz,jy) + ELSE + an(ix,1,kz,lni) = 0.0 + ENDIF + an(ix,1,kz,lns) = csw(ix,kz,jy) + an(ix,1,kz,lnh) = chw(ix,kz,jy) + IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,kz,jy) + ENDIF + IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy) + IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy) + + + + + + + IF ( present( tt ) ) THEN + t0(ix,1,kz) = tt(ix,kz,jy) ! temperature (Kelvin) + ELSE + t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin) + ENDIF + t1(ix,1,kz) = 0.0 + t2(ix,1,kz) = 0.0 + t3(ix,1,kz) = 0.0 + t4(ix,1,kz) = 0.0 + t5(ix,1,kz) = 0.0 + t6(ix,1,kz) = 0.0 + t7(ix,1,kz) = 0.0 + t8(ix,1,kz) = 0.0 + t9(ix,1,kz) = 0.0 + t00(ix,1,kz) = 380.0/p(ix,kz,jy) + t77(ix,1,kz) = pii(ix,kz,jy) + dbz2d(ix,1,kz) = 0.0 + vzf2d(ix,1,kz) = 0.0 + + dn1(ix,1,kz) = dn(ix,kz,jy) + pn(ix,1,kz) = p(ix,kz,jy) + wn(ix,1,kz) = w(ix,kz,jy) +! wmax = Max(wmax,wn(ix,1,kz)) + dz2d(ix,1,kz) = dz(ix,kz,jy) + dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy) + + ltemq = Int( (t0(ix,1,kz)-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) +! +! saturation mixing ratio +! + t8s = t00(ix,1,kz)*tabqvs(ltemq) !saturation mixing ratio wrt water + t9s = t00(ix,1,kz)*tabqis(ltemq) !saturation mixing ratio wrt ice + +! +! calculate rate of nucleation +! + ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + + if ( ssival .gt. 1.0 ) then +! + IF ( icenucopt == 1 ) THEN + + if ( t0(ix,1,kz).le.268.15 ) then + + dp1 = dn1(ix,1,kz)/rho00*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) + t7(ix,1,kz) = Min(dp1, 1.0d30) + end if + +! +! Default value of imeyers5 turns off nucleation by Meyer at higher temperatures +! This is really from Ferrier (1994), eq. 4.31 - 4.34 + IF ( imeyers5 ) THEN + if ( t0(ix,1,kz).lt.tfr .and. t0(ix,1,kz).gt.268.15 ) then + qvapor = max(an(ix,1,kz,lv),0.0) + ssifac = 0.0 + if ( (qvapor-t9s) .gt. 1.0e-5 ) then + if ( (t8s-t9s) .gt. 1.0e-5 ) then + ssifac = (qvapor-t9s) /(t8s-t9s) + ssifac = ssifac**cnin1a + end if + end if + t7(ix,1,kz) = dn1(ix,1,kz)/rho00*cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1) + end if + ENDIF + +! t7max = Max(t7max, t7(ix,1,kz) ) + + ELSEIF ( icenucopt == 2 ) THEN ! Thompson/Cooper; Note Thompson 2004 has constants of + ! 0.005 and 0.304 because the line function was estimated from Cooper plot + ! Here, the fit line values from Cooper 1986 are converted. Very little difference + ! in practice + + t7(ix,1,kz) = 1000.*0.00446684*exp(0.3108*(273.16 - Max(233.0, t0(ix,1,kz) ) ) ) ! factor of 1000 to convert L**-1 to m**-3 + +! write(0,*) 'Cooper t7,ssival = ',ix,kz,t7(ix,1,kz),ssival + + ELSEIF ( icenucopt == 3 ) THEN ! Phillips (Meyers/DeMott) + + if ( t0(ix,1,kz).le.268.15 .and. t0(ix,1,kz) > 243.15 ) then ! Meyers with factor of Psi=0.06 + + dp1 = 0.06*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) + t7(ix,1,kz) = Min(dp1, 1.0d30) + elseif ( t0(ix,1,kz) <= 243.15 ) then ! Phillips estimate of DeMott et al (2003) data + dp1 = 1000.*( exp( Min( 57.0 ,cnin2a*(ssival-1.1) ) ) )**0.3 + t7(ix,1,kz) = Min(dp1, 1.0d30) + + end if + + ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 + + IF ( t0(ix,jy,kz) < 268.16 .and. t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + + ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033, + ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d) + ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00 + ! naer needs units of cm**-3, so mult by 1.e-6 + + ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) + dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) + t7(ix,jy,kz) = Min(dp1, 1.0d30) + + ELSE + t7(ix,jy,kz) = 0.0 + ENDIF + + ENDIF ! icenucopt + + +! + end if ! ( ssival .gt. 1.0 ) +! + + ENDDO ! ix + ENDDO ! kz + + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF + + + ! transform from number mixing ratios to number conc. + + DO il = lnb,na + IF ( denscale(il) == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy) + ENDDO + ENDDO + ENDIF + ENDDO ! il + +! sedimentation + xfall(:,:,:) = 0.0 + + IF ( .true. ) THEN + + +! #ifndef CM1 +! for real cases when hydrometeor mixing ratios have been initialized without concentrations + IF ( itimestep == 1 .and. ipconc > 0 ) THEN + call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) + ENDIF +! #endif + + IF ( present(cu_used) .and. & + ( present( qrcuten ) .or. present( qscuten ) .or. & + present( qicuten ) .or. present( qccuten ) ) ) THEN + + IF ( cu_used == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + + IF ( present( qrcuten ) ) ancuten(ix,1,kz,lr) = dtp*qrcuten(ix,kz,jy) + IF ( present( qscuten ) ) ancuten(ix,1,kz,ls) = dtp*qscuten(ix,kz,jy) + IF ( present( qicuten ) ) ancuten(ix,1,kz,li) = dtp*qicuten(ix,kz,jy) + IF ( present( qccuten ) ) ancuten(ix,1,kz,lc) = dtp*qccuten(ix,kz,jy) + + ENDDO + ENDDO + + call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) + + + ENDIF + + ENDIF + + + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & + & t0,t7,infdo,jy,its,jts & + & ,timesed1,timesed2,timesed3,zmaxsed,timesetvt) + + +! copy xfall to appropriate places... + +! write(0,*) 'N2M: end sediment, jy = ',jy + + DO ix = its,ite + IF ( lhl > 1 ) THEN + RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) + ELSE + RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) ) + ENDIF + IF ( present ( rainncw2 ) ) THEN ! rain only + rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) + ENDIF + IF ( present ( rainnci2 ) ) THEN ! ice only + IF ( lhl > 1 ) THEN + rainnci2(ix,jy) =rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) + ELSE + rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) ) + ENDIF + ENDIF + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) + IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) + + IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + IF ( lhl > 1 ) THEN +!#ifdef CM1 +! IF ( .true. ) THEN +!#else + IF ( present( HAILNC ) ) THEN +!#endif + HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) + ELSEIF ( present( GRPLNCV ) ) THEN + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + ENDIF + ENDIF + IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) + IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN + IF ( present( HAILNC ) ) THEN + SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) + ELSE + SR(ix,jy) = (SNOWNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) + ENDIF + ENDIF + ENDDO + + ENDIF ! .false. + + IF ( isedonly /= 1 ) THEN + ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics + +! write(0,*) 'N2M: gs, jy = ',jy +! IF ( isedonly /= 2 ) THEN + + + IF ( .true. ) THEN + call nssl_2mom_gs & + & (nx,ny,nz,na,jy & + & ,nor,nor & + & ,dtp,dz2d & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn1,t77 & + & ,pn,wn,0 & + & ,t00,t77, & + & ventr,ventc,c1sw,1,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & + & cdx, & + & xdn0,dbz2d,tke2d, & + & timevtcalc,axtra2d, makediag & + & ,rainprod2d, evapprod2d & + & ,elec2,its,ids,ide,jds,jde & + & ) + ENDIF + + + + + + ENDIF ! isedonly /= 1 + + ! droplet nucleation/condensation/evaporation + IF ( .true. ) THEN + CALL NUCOND & + & (nx,ny,nz,na,jy & + & ,nor,nor,dtp,nx & + & ,dz2d & + & ,t0,t9 & + & ,an,dn1,t77 & + & ,pn,wn & + & ,axtra2d, makediag & + & ,ssat,t00,t77,flag_qndrop) + + + ENDIF + + + IF ( present( pcc2 ) .and. makediag ) THEN + DO kz = kts,kte + DO ix = its,ite +! example of using the 'axtra2d' array to get rates out of the microphysics routine for output. +! Search for 'axtra' to find example code below +! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1) + + ENDDO + ENDDO + ENDIF + + +! compute diagnostic S-band reflectivity if needed + IF ( present( dbz ) .and. makediag ) THEN + ! calc dbz + + IF ( .true. ) THEN + IF ( present(ke_diag) ) THEN + kediagloc = ke_diag + ELSE + kediagloc = nz + ENDIF + call radardd02(nx,ny,nz,nor,na,an,t0, & + & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0) + ENDIF ! .false. + + + DO kz = kts,kediagloc ! kte + DO ix = its,ite + dbz(ix,kz,jy) = dbz2d(ix,1,kz) + IF ( present( vzf ) ) THEN + vzf(ix,kz,jy) = vzf2d(ix,1,kz) + IF ( dbz2d(ix,1,kz) <= 0.0 ) THEN + vzf(ix,kz,jy) = 0.0 + ELSEIF ( dbz2d(ix,1,kz) <= 15.0 ) THEN + refl = 10**(0.1*dbz2d(ix,1,kz)) + vzf(ix,kz,jy) = Min( vzf2d(ix,1,kz), 2.6 * Max(0.0,refl)**0.107 * (1.2/dn1(ix,1,kz))**0.4 ) + ENDIF + ENDIF + IF ( present( compdbz ) ) THEN + compdbz(ix,jy) = Max( compdbz(ix,jy), dbz2d(ix,1,kz) ) + ENDIF + ENDDO + ENDDO + + ENDIF + + + +! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F + IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & + present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN + IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = 2.51E-6 + re_ice(ix,kz,jy) = 10.01E-6 + re_snow(ix,kz,jy) = 25.E-6 + t1(ix,1,kz) = 2.51E-6 + t2(ix,1,kz) = 10.01E-6 + t3(ix,1,kz) = 25.E-6 + ENDDO + ENDDO + + call calc_eff_radius & + & (nx,ny,nz,na,jy & + & ,nor,nor & + & ,t1,t2,t3 & + & ,an,dn1 ) + + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6)) + re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 125.E-6)) + re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) + ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation) + IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) + ENDDO + ENDDO + + ENDIF + ENDIF + + + + +! transform concentrations back to mixing ratios + DO il = lnb,na + IF ( denscale(il) == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy) + ENDDO + ENDDO + ENDIF + ENDDO ! il + + ! copy 2D slabs back to 3D + + + DO kz = kts,kte + DO ix = its,ite + + IF ( present( tt ) ) THEN + tt(ix,kz,jy) = t0(ix,1,kz) + ELSE + th(ix,kz,jy) = an(ix,1,kz,lt) + ENDIF + + qv(ix,kz,jy) = an(ix,1,kz,lv) + qc(ix,kz,jy) = an(ix,1,kz,lc) + qr(ix,kz,jy) = an(ix,1,kz,lr) + IF ( present(qi) ) qi(ix,kz,jy) = an(ix,1,kz,li) + qs(ix,kz,jy) = an(ix,1,kz,ls) + qh(ix,kz,jy) = an(ix,1,kz,lh) + IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) + + IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN + nwfa(ix,kz,jy) = an(ix,1,kz,lccn) +! nwfa(ix,kz,jy) = Min(1.5e9, nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp) + IF ( kz == 1 ) nwfa(ix,kz,jy) = nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp + ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN + IF ( invertccn ) THEN + cn(ix,kz,jy) = qccn - an(ix,1,kz,lccn) + ELSE + cn(ix,kz,jy) = an(ix,1,kz,lccn) + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + IF ( present( cna ) .and. f_cnatmp ) THEN + cna(ix,kz,jy) = an(ix,1,kz,lccna) + ENDIF + ENDIF + + IF ( lcin > 1 .and. flag_qnifa ) THEN + nifa(ix,kz,jy) = an(ix,1,kz,lcin) + ENDIF + + IF ( ipconc >= 5 ) THEN + + ccw(ix,kz,jy) = an(ix,1,kz,lnc) + crw(ix,kz,jy) = an(ix,1,kz,lnr) + IF ( present( cci ) ) cci(ix,kz,jy) = an(ix,1,kz,lni) + csw(ix,kz,jy) = an(ix,1,kz,lns) + chw(ix,kz,jy) = an(ix,1,kz,lnh) + IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl) + ENDIF + + + + + IF ( lvh > 0 ) vhw(ix,kz,jy) = an(ix,1,kz,lvh) + IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl) + +#ifdef WRF_CHEM + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) + IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) + ENDIF +#endif + ENDDO + ENDDO + + ENDDO ! jy + + IF ( invertccn .and. present( cn ) ) THEN ! hack to convert unactivated ccn back to activated + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite +! cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) + ENDDO + ENDDO + ENDDO + ENDIF + + + + + + RETURN +END SUBROUTINE nssl_2mom_driver + +! ##################################################################### +! ##################################################################### + + REAL FUNCTION GAMMA_SP(xx) + + implicit none + real xx + integer j + +! Double precision ser,stp,tmp,x,y,cof(6) + + real*8 ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d+0, & + & -86.50532032941677d0, & + & 24.01409824083091d0, & + & -1.231739572450155d0, & + & 0.1208650973866179d-2,& + & -0.5395239384953d-5, & + & 2.5066282746310005d0/ + + IF ( xx <= 0.0 ) THEN + write(0,*) 'Argument to gamma must be > 0!! xx = ',xx + STOP + ENDIF + + x = xx + y = x + tmp = x + 5.5d0 + tmp = (x + 0.5d0)*Log(tmp) - tmp + ser = 1.000000000190015d0 + DO j=1,6 + y = y + 1.0d0 + ser = ser + cof(j)/y + END DO + gamma_sp = Exp(tmp + log(stp*ser/x)) + + RETURN + END FUNCTION GAMMA_SP + +! ##################################################################### + + DOUBLE PRECISION FUNCTION GAMMA_DPR(x) + ! dp gamma with real input + implicit none + real :: x + double precision :: xx + + xx = x + + gamma_dpr = gamma_dp(xx) + + return + end FUNCTION GAMMA_DPR + + + + +! ##################################################################### + + real function GAMXINF(A1,X1) + +! =================================================== +! Purpose: Compute the incomplete gamma function +! from x to infinity +! Input : a --- Parameter ( a 170 ) +! x --- Argument +! Output: GIM --- gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing gamma(x) +! =================================================== + +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + real :: a1,x1 + double precision :: xam,dlog,s,r,ga,t0,a,x + integer :: k + double precision :: gin, gim + + a = a1 + x = x1 + IF ( x1 <= 0.0 ) THEN + gamxinf = GAMMA_SP(A1) + return + ENDIF + XAM=-X+A*DLOG(X) + IF (XAM.GT.700.0.OR.A.GT.170.0) THEN + WRITE(*,*)'a and/or x too large' + STOP + ENDIF + IF (X.EQ.0.0) THEN + GIN=0.0 + GIM = GAMMA_SP(A1) + ELSE IF (X.LE.1.0+A) THEN + S=1.0D0/A + R=S + DO 10 K=1,60 + R=R*X/(A+K) + S=S+R + IF (DABS(R/S).LT.1.0D-15) GO TO 15 +10 CONTINUE +15 GIN=DEXP(XAM)*S + ga = GAMMA_SP(A1) + GIM=GA-GIN + ELSE IF (X.GT.1.0+A) THEN + T0=0.0D0 + DO 20 K=60,1,-1 + T0=(K-A)/(1.0D0+K/(X+T0)) +20 CONTINUE + GIM=DEXP(XAM)/(X+T0) +! GA = GAMMA_SP(A1) +! GIN=GA-GIM + ENDIF + + gamxinf = GIM + return + END function GAMXINF + +! ##################################################################### + + double precision function GAMXINFDP(A1,X1) + +! =================================================== +! Purpose: Compute the incomplete gamma function +! from x to infinity +! Input : a --- Parameter ( a < 170 ) +! x --- Argument +! Output: GIM --- Gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing gamma_dp(x) +! =================================================== + +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + real :: a1,x1 +! dont declare gamma_dp because it is within the module +! double precision :: gamma_dp + double precision :: xam,dlog,s,r,ga,t0,a,x + integer :: k + double precision :: gin, gim + + a = a1 + x = x1 + IF ( x1 <= 0.0 ) THEN + gamxinfdp = GAMMA_DP(A) + return + ENDIF + XAM=-X+A*DLOG(X) + IF (XAM.GT.700.0.OR.A.GT.170.0) THEN + WRITE(*,*)'a and/or x too large' + STOP + ENDIF + IF (X.EQ.0.0) THEN + GIN=0.0 + GIM = GAMMA_dp(A) + ELSE IF (X.LE.1.0+A) THEN + S=1.0D0/A + R=S + DO 10 K=1,60 + R=R*X/(A+K) + S=S+R + IF (DABS(R/S).LT.1.0D-15) GO TO 15 +10 CONTINUE +15 GIN=DEXP(XAM)*S + ga = GAMMA_DP(A) + GIM=GA-GIN + ELSE IF (X.GT.1.0+A) THEN + T0=0.0D0 + DO 20 K=60,1,-1 + T0=(K-A)/(1.0D0+K/(X+T0)) +20 CONTINUE + GIM=DEXP(XAM)/(X+T0) +! GA = GAMMA_dp(A) +! GIN=GA-GIM + ENDIF + + gamxinfdp = GIM + return + END function GAMXINFDP + + +! ##################################################################### + +! #ifdef Z3MOM + real function gaminterp(ratio, alp, luindex, ilh) + + implicit none + + real, intent(in) :: ratio, alp + integer, intent(in) :: ilh ! 1 = graupel, 2 = hail + integer, intent(in) :: luindex ! which argument: + ! gamxinflu(i,j,1,1) = x/y + ! gamxinflu(i,j,2,1) = gamxinf( 2.0+alp, ratio )/y + ! gamxinflu(i,j,3,1) = gamxinf( 2.5+alp+0.5*bxh, ratio )/y + ! gamxinflu(i,j,5,1) = gamxinf( 5.0+alp, ratio )/y + ! gamxinflu(i,j,6,1) = gamxinf( 5.5+alp+0.5*bxh, ratio )/y + + + real :: delx, dely, tmp1, tmp2, temp3 + integer :: i,j,ip1,jp1 !,ilh + +! ilh = Abs(ilh0) + + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + delx = Min(maxratiolu,ratio) - float(i)*dqiacrratio + dely = alp - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = gamxinflu(i,j,luindex,ilh) + delx*dqiacrratioinv* & + & (gamxinflu(ip1,j,luindex,ilh) - gamxinflu(i,j,luindex,ilh)) + tmp2 = gamxinflu(i,jp1,luindex,ilh) + delx*dqiacrratioinv* & + & (gamxinflu(ip1,jp1,luindex,ilh) - gamxinflu(i,jp1,luindex,ilh)) + + ! interpolate along alpha; + + gaminterp = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1)) + + ! debug +! IF ( ilh0 < 0 ) THEN +! write(0,*) 'gaminterp: ',i,j,ilh,ratio,delx,dely,gamxinflu(i,j,luindex,ilh),tmp1,tmp2 +! ENDIF + + END FUNCTION gaminterp +! #endif /* Z3MOM */ +! ##################################################################### + +!**************************** GAML02 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 40 micron drops) +! ********************************************************** + real FUNCTION GAML02(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=12) + real gamxg(ng), xg(ng) + DATA xg/0.01,0.02,0.025,0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 7.391019203578037e-8,0.02212726874591478,0.06959352407989682, & + & 0.2355654024970809,0.46135930387500346,0.545435791452399, & + & 0.7371571313308203, & + & 0.8265676632204345,0.8640182781845841,0.8855756211304151, & + & 0.9245079225301251, & + & 0.9712578342732681/ + IF ( x .ge. xg(ng) ) THEN + gaml02 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + gaml02 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + gaml02 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02 + +!**************************** GAML02d300 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb) +! ********************************************************** + real FUNCTION GAML02d300(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=9) + real gamxg(ng), xg(ng) + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 0.0, & + & 7.391019203578011e-8,0.0002260640810600053, & + & 0.16567071824457152, & + & 0.4231369044918005,0.5454357914523988, & + & 0.6170290936864555, & + & 0.7471346054110058,0.9037156157718299 / + IF ( x .ge. xg(ng) ) THEN + GAML02d300 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + GAML02d300 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + GAML02d300 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02d300 +!c + +! ##################################################################### +! ##################################################################### + +!**************************** GAML02 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 500 micron drops) (see zieglerstuff.nb) +! ********************************************************** + real FUNCTION GAML02d500(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=9) + real gamxg(ng), xg(ng) + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 0.0,0.0, & + & 2.2346039e-13, 0.0221272687459, & + & 0.23556540, 0.38710348, & + & 0.48136183,0.6565833, & + & 0.86918315 / + IF ( x .ge. xg(ng) ) THEN + GAML02d500 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + GAML02d500 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + GAML02d500 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02d500 +!c + +! ##################################################################### + +! ##################################################################### + + + real function BETA(P,Q) +! +! ========================================== +! Purpose: Compute the beta function B(p,q) +! Input : p --- Parameter ( p > 0 ) +! q --- Parameter ( q > 0 ) +! Output: BT --- B(p,q) +! Routine called: GAMMA for computing gamma(x) +! ========================================== +! +! IMPLICIT real (A-H,O-Z) + implicit none + double precision p1,gp,q1,gq, ppq,gpq + real p,q + + p1 = p + q1 = q + CALL GAMMADP(P1,GP) + CALL GAMMADP(Q1,GQ) + PPQ=P1+Q1 + CALL GAMMADP(PPQ,GPQ) + beta=GP*GQ/GPQ + RETURN + END function BETA + +! ##################################################################### +! ##################################################################### + + DOUBLE PRECISION FUNCTION GAMMA_DP(xx) + + implicit none + double precision xx + integer j + +! Double precision ser,stp,tmp,x,y,cof(6) + + real*8 ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d+0, & + & -86.50532032941677d0, & + & 24.01409824083091d0, & + & -1.231739572450155d0, & + & 0.1208650973866179d-2,& + & -0.5395239384953d-5, & + & 2.5066282746310005d0/ + + x = xx + y = x + tmp = x + 5.5d0 + tmp = (x + 0.5d0)*Log(tmp) - tmp + ser = 1.000000000190015d0 + DO j=1,6 + y = y + 1.0d0 + ser = ser + cof(j)/y + END DO + gamma_dp = Exp(tmp + log(stp*ser/x)) + + RETURN + END function gamma_dp +! ##################################################################### + + SUBROUTINE GAMMADP(X,GA) +! +! ================================================== +! Purpose: Compute gamma function Gamma(x) +! Input : x --- Argument of Gamma(x) +! ( x is not equal to 0,-1,-2,...) +! Output: GA --- gamma(x) +! ================================================== +! +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + + double precision, parameter :: PI=3.141592653589793D0 + double precision :: x,ga,z,r,gr + integer :: k,m1,m + + double precision :: G(26) + + IF (X.EQ.INT(X)) THEN + IF (X.GT.0.0D0) THEN + GA=1.0D0 + M1=X-1 + DO K=2,M1 + GA=GA*K + ENDDO + ELSE + GA=1.0D+300 + ENDIF + ELSE + IF (DABS(X).GT.1.0D0) THEN + Z=DABS(X) + M=INT(Z) + R=1.0D0 + DO K=1,M + R=R*(Z-K) + ENDDO + Z=Z-M + ELSE + Z=X + ENDIF + DATA G/1.0D0,0.5772156649015329D0, & + & -0.6558780715202538D0, -0.420026350340952D-1, & + & 0.1665386113822915D0,-.421977345555443D-1, & + & -.96219715278770D-2, .72189432466630D-2, & + & -.11651675918591D-2, -.2152416741149D-3, & + & .1280502823882D-3, -.201348547807D-4, & + & -.12504934821D-5, .11330272320D-5, & + & -.2056338417D-6, .61160950D-8, & + & .50020075D-8, -.11812746D-8, & + & .1043427D-9, .77823D-11, & + & -.36968D-11, .51D-12, & + & -.206D-13, -.54D-14, .14D-14, .1D-15/ + GR=G(26) + DO K=25,1,-1 + GR=GR*Z+G(K) + ENDDO + GA=1.0D0/(GR*Z) + IF (DABS(X).GT.1.0D0) THEN + GA=GA*R + IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X)) + ENDIF + ENDIF + RETURN + END SUBROUTINE GAMMADP + + +! ##################################################################### +! ##################################################################### +! +! +! ##################################################################### + Function delbk(bb,nu,mu,k) +! +! Purpose: Caluculates collection coefficients following Siefert (2006) +! +! delbk is equation (90) (b collecting b -- self-collection) +! mass-diameter relationship: D = a*x**(b), where x = particle mass +! general distribution: n(x) = A*x**(nu)*Exp(-lam*x**(mu)) +! where +! A = mu*N/(Gamma((nu+1)/mu)) *lam**((nu+1)/mu) +! +! lam = ( Gamma((nu+1)/mu)/Gamma((nu+2)/mu) * xbar )**(-mu) +! +! where xbar = L/N (mass content)/(number concentration) = q*rhoa/N +! + + implicit none + real delbk + real nu, mu, bb + integer k + + real tmp, del + real x1, x2, x3, x4 + integer i + + tmp = ((1.0 + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x1 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((2.0 + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x2 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1.0 + 2.0*bb + k + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x3 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! delbk = & +! & ((Gamma_sp((1.0 + nu)/mu)/Gamma_sp((2.0 + nu)/mu))**(2.0*bb + k)* & +! & Gamma_sp((1.0 + 2.0*bb + k + nu)/mu))/Gamma_sp((1.0 + nu)/mu) + + delbk = & + & ((x1/x2)**(2.0*bb + k)* & + & x3)/x1 + + RETURN + END Function delbk + +! ##################################################################### +! +! +! ##################################################################### +! Equation (91) in Seifert and Beheng (2006) ("a" collecting "b") + Function delabk(ba,bb,nua,nub,mua,mub,k) + + implicit none + real delabk + real nua, mua, ba + integer k + real nub, mub, bb + + integer i + real tmp,del + + real g1pnua, g2pnua, g1pbapnua, g1pbbpk, g1pnub, g2pnub + + tmp = (1. + nua)/mua + i = Int(dgami*(tmp)) + del = tmp - dgam*i + IF ( i+1 > ngm0 ) THEN + write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp + STOP + ENDIF + g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua) + + tmp = ((2. + nua)/mua) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g2pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + ba + nua)/mua) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pbapnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((2 + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g2pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + bb + k + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pbbpk = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + delabk = & + & (2.*(g1pnua/g2pnua)**ba* & + & g1pbapnua* & + & (g1pnub/g2pnub)**(bb + k)* & + & g1pbbpk)/ & + & (g1pnua*g1pnub) + + RETURN + END Function delabk + + +! ##################################################################### +! +! ##################################################################### +!-------------------------------------------------------------------------- + subroutine cld_cpu(string) + + implicit none + character( LEN = * ) string + + return + + end subroutine cld_cpu + +! +!-------------------------------------------------------------------------- +! +!-------------------------------------------------------------------------- +! + subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & + & t0,t7,infdo,jslab,its,jts, & + & timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing +! +! Sedimentation driver -- column by column +! +! Written by ERM 10/2011 +! +! +! + implicit none + + integer nx,ny,nz,nor,norz,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density + integer :: its,jts ! SW point of local tile + + integer ng1 + parameter(ng1 = 1) + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real dz3dinv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + +! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) + real dtp + real xfall(nx,ny,na) ! array for stuff landing on the ground + real xfall0(nx,ny) ! dummy array + integer infdo + integer jslab ! which line of xfall to use + + integer ix,jy,kz,ndfall,n,k,il,in + real tmp, vtmax, dtptmp, dtfrac + real, parameter :: dz = 200. + + real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted + real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) + real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + + real :: rhovtzx(nz,nx) + + double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy + double precision :: dt1,dt2,dt3,dt4 + + integer,parameter :: ngs = 128 + integer :: ngscnt,mgs,ipconc0 + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + logical :: hasmass(nx,lc+1:lhab) + + integer igs(ngs),kgs(ngs) + + real rho0(ngs),temcg(ngs) + + real temg(ngs) + + real rhovt(ngs) + + real cwnc(ngs),cinc(ngs) + real fadvisc(ngs),cwdia(ngs),cipmas(ngs) + + real cimasn,cimasx,cnina(ngs),cimas(ngs) + + real cnostmp(ngs) + + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + integer :: plo, phi + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + + + + kzb = 1 + kze = nz + + ixb = 1 + ixe = nx + + + jy = 1 + jgs = jy + + +! +! zero the precip flux arrays (2d) +! + + xvt(:,:,:,:) = 0.0 + + if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' + + + DO kz = kzb,kze + DO ix = ixb,ixe + db1(ix,kz) = dn(ix,jy,kz) + db1inv(ix,kz) = 1./dn(ix,jy,kz) + rhovtzx(kz,ix) = Sqrt(rho00*db1inv(ix,kz) ) + ENDDO + ENDDO + + DO kz = kzb,kze + DO ix = ixb,ixe + dtz1(kz,ix,0) = dz3dinv(ix,jy,kz) + dtz1(kz,ix,1) = dz3dinv(ix,jy,kz)*db1inv(ix,kz) + dz2dinv(kz,ix) = dz3dinv(ix,jy,kz) + ENDDO + ENDDO + + IF ( lzh .gt. 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + an(ix,jy,kz,lzh) = Max( 0., an(ix,jy,kz,lzh) ) + ENDDO + ENDDO + ENDIF + + + DO il = lc+1,lhab + DO ix = ixb,ixe +! hasmass(ix,il) = Any( an(ix,jy,:,il) > qxmin(il) ) + ENDDO + ENDDO + + + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3a2' + +! loop over columns + DO ix = ixb,ixe + + dummy = 0.d0 + + + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,0 & + & ) + + +! loop over each species and do sedimentation for all moments + DO il = lc,lhab + IF ( ido(il) == 0 ) CYCLE + +! IF ( .not. hasmass(ix,il) ) CYCLE + +! plo = nz +! phi = 0 + + + vtmax = 0.0 + + do kz = kzb,kze + + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) + + vtmax = Max(vtmax,xvt(kz,ix,1,il)*dz2dinv(kz,ix)) + vtmax = Max(vtmax,xvt(kz,ix,2,il)*dz2dinv(kz,ix)) + vtmax = Max(vtmax,xvt(kz,ix,3,il)*dz2dinv(kz,ix)) + +! IF ( dtp*xvt(kz,ix,1,il)*dz2dinv(kz,ix) >= 0.7 .or. & +! & dtp*xvt(kz,ix,2,il)*dz2dinv(kz,ix) >= 0.7 .or. & +! & dtp*xvt(kz,ix,3,il)*dz2dinv(kz,ix) >= 0.7 ) THEN +! +! zmaxsed = Max(zmaxsed, float(kz) ) +!! plo = Min(plo,kz) +!! phi = Max(phi,kz) +! +! ENDIF + + ENDDO + + IF ( vtmax == 0.0 ) CYCLE + + + + IF ( dtp*vtmax .lt. 0.7 ) THEN ! check whether multiple steps are needed. + ndfall = 1 + ELSE + IF ( dtp > 20.0 ) THEN ! more stringent subdivision for large time steps + ndfall = Max(2, Int(dtp*vtmax/0.7) + 1) + ELSE ! more relaxed for small time steps, but might still be a problem for very thin vertical layers near the ground + ndfall = 1+Int(dtp*vtmax + 0.301) + ENDIF + ENDIF + + IF ( ndfall .gt. 1 ) THEN + dtptmp = dtp/Real(ndfall) +! write(0,*) 'subdivide fallout on its,jts,ix,plo,phi = ',its,jts,ix,plo,phi +! write(0,*) 'for il,jsblab,c,ndfall = ',il,jslab,dtp*vtmax,ndfall + ELSE + dtptmp = dtp + ENDIF + + dtfrac = dtptmp/dtp + + + DO n = 1,ndfall + + IF ( do_accurate_sedimentation .and. n .ge. 2 ) THEN +! +! zero the precip flux arrays (2d) +! + +! xvt(:,:,:,il) = 0.0 + dummy = 0.d0 + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,il) + + + DO kz = kzb,kze + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) + ENDDO + + + + + ENDIF ! (n .ge. 2) + + + IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN + IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN + call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & + & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix ) + ENDIF + ENDIF + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b' + +! mixing ratio + + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & an,db1,il,1,xfall,dtz1,ix) + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3c' + +! volume + + IF ( ldovol .and. il >= li ) THEN + IF ( lvol(il) .gt. 1 ) THEN + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & an,db1,lvol(il),0,xfall,dtz1,ix) + ENDIF + ENDIF + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' + + + IF ( ipconc .gt. 0 ) THEN !{ + IF ( ipconc .ge. ipc(il) ) THEN + + IF ( ( infall .ge. 2 .or. (infall .eq. 0 .and. il .lt. lh) ) .and. lz(il) .lt. 1) THEN !{ +! +! load number conc. into tmpn to do fallout by mass-weighted mean fall speed +! to put a lower bound on number conc. +! + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or. & + & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN + + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn2(ix,jy,kz) = z(ix,kz,il) +! ENDDO + ENDDO + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) +! ENDDO + ENDDO + + ELSE + + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) +! ENDDO + ENDDO + + ENDIF + + ENDIF !} + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f' + + in = 2 + IF ( infall .eq. 1 ) in = 1 + + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), & + & an,db1,ln(il),0,xfall,dtz1,ix) + + + IF ( lz(il) .lt. 1 ) THEN ! if not 3-moment, run one of the correction schemes + IF ( (infall .ge. 2 .or. infall .eq. 3) .and. .not. (infall .eq. 0 .and. il .ge. lh) & + & .and. ( il .eq. lr .or. (il .ge. li .and. il .le. lhab) )) THEN +! : .or. il .eq. lhl )) THEN + + xfall0(:,jgs) = 0.0 + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & + & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & + & tmpn2,db1,1,0,xfall0,dtz1,ix) + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & tmpn,db1,1,0,xfall0,dtz1,ix) + ELSE + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & tmpn,db1,1,0,xfall0,dtz1,ix) + ENDIF + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & + & .or. il .ge. lh ) ) THEN +! "Method I" - dbz correction + + call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & + & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, & + & lvol(il), rho_qh, infall, ix) + + ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN + + DO kz = kzb,kze +! DO ix = ixb,ixe + an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), 0.5* ( an(ix,jgs,kz,ln(il)) + tmpn(ix,jy,kz) )) + +! ENDDO + ENDDO + + ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN +! "Method II" M-wgt N-fallout correction + + DO kz = kzb,kze +! DO ix = ixb,ixe + + an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), tmpn(ix,jy,kz) ) + +! ENDDO + ENDDO + ENDIF + ENDIF ! lz(il) .lt. 1 + + + ENDIF + ENDIF + + + ENDIF !} + + + ENDDO ! n=1,ndfall + ENDDO ! il + + ENDDO ! ix + + + + + RETURN + END SUBROUTINE SEDIMENT1D + + +! ##################################################################### + +! +! ##################################################################### + + +! +!-------------------------------------------------------------------------- +! +!-------------------------------------------------------------------------- +! + subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & + & a,db1,ia,id,xfall,dtz1,ixcol) +! +! First-order, upwind fallout scheme +! +! Written by ERM 6/10/2011 +! +! +! + implicit none + + integer nx,ny,nz,nor,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density + integer ng1 + parameter(ng1 = 1) + integer :: ixcol + +! real dz3dinv(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) +! real a(nx,ny,nz,na) + real a(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) ! quantity to be 'advected' + real vt(nz+1,nx) ! terminal speed for a + real dtp,dtfrac + real cmax + real xfall(nx,ny,na) ! array for stuff landing on the ground + real db1(nx,nz+1),dtz1(nz+1,nx,0:1) + +! Local + + integer ix,jy,kz,n,k + integer iv1,iv2 + real tmp + integer imn,imx,kmn,kmx + real qtmp1(nz+1) + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + jy = 1 + + iv1 = 0 + iv2 = 0 + + imn = nx + imx = 1 + kmn = nz + kmx = 1 + + cmax = 0.0 + + kzb = 1 + kze = nz + + ixb = ixcol + ixe = ixcol + ix = ixcol + + qtmp1(nz+1) = 0.0 + + DO kz = kzb,kze +! DO ix = ixb,ixe +! cmax = Max(cmax, vt(ix,kz)*dz3dinv(ix,jy,kz)) + + IF ( id == 1 ) THEN + qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix)*db1(ix,kz) + ELSE + qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix) + ENDIF + + IF ( a(ix,jgs,kz,ia) .ne. 0.0 ) THEN +! imn = Min(ix,imn) +! imx = Max(ix,imx) + kmn = Min(kz,kmn) + kmx = Max(kz,kmx) + ENDIF +! ENDDO + ENDDO + + kmn = Max(1,kmn-1) + +! first check if fallout is worth doing +! IF ( cmax .eq. 0.0 .or. imn .gt. imx ) THEN +! RETURN +! ENDIF + + IF ( kmn == 1 ) THEN + + kz = 1 +! do ix = imn,imx ! 1,nx-1 + xfall(ix,jy,ia) = xfall(ix,jy,ia) + a(ix,jgs,kz,ia)*vt(kz,ix)*dtfrac +! enddo + + ENDIF + + do kz = 1,nz +! do ix = 1,nx + a(ix,jgs,kz,ia) = a(ix,jgs,kz,ia) + dtp*dtz1(kz,ix,id)*(qtmp1(kz+1) - qtmp1(kz) ) +! enddo + enddo + + + RETURN + END SUBROUTINE FALLOUT1D + +! ############################################################################## +! ############################################################################## + + subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & + & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol) + + + implicit none + + integer nx,ny,nz,nor,na,ngt,jgs + integer :: ixcol + integer, parameter :: norz = 3 + real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) + real z(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! reflectivity + real db(nx,nz+1) ! air density +! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt) + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer l ! index for q + integer ln ! index for N + integer lvol ! index for volume + real rho_qx + + + integer ix,jy,kz + real vr,qr,nrx,rd,xv,g1,zx,chw,xdn + + + jy = jgs + ix = ixcol + + IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN + + + DO kz = 1,kze + + + + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN + + IF ( lvol .gt. 1 ) THEN + IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN + xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) + xdn = Min( 900., Max( hdnmn, xdn ) ) + ELSE + xdn = rho_qx + ENDIF + ELSE + xdn = rho_qx + ENDIF + + IF ( l == lr ) xdn = 1000. + + qr = a(ix,jy,kz,l) + xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + chw = a(ix,jy,kz,ln) + + IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN + xv = Min( xvmx, Max( xvmn,xv ) ) + chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + ENDIF + + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & + & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) + zx = g1*db(ix,kz)**2*(a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw +! z(ix,kz,l) = 1.e18*zx*(6./(pi*1000.))**2 + z(ix,kz,l) = zx*(6./(pi*1000.))**2 + + +! IF ( ny.eq.2 .and. kz .ge. 25 .and. kz .le. 29 .and. z(ix,kz,l) .gt. 0. ) THEN +! write(*,*) 'calczgr: z,dbz,xdn = ',ix,kz,z(ix,kz,l),10*log10(z(ix,kz,l)),xdn +! ENDIF + + ELSE + + z(ix,kz,l) = 0.0 + + ENDIF + + ENDDO + + ELSEIF ( l .eq. lr .and. imurain == 3) THEN + + xdn = 1000. + + DO kz = 1,kze + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) +! z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) + z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) +! qr = a(ix,jy,kz,lr) +! nrx = a(ix,jy,kz,lnr) + + ELSE + + z(ix,kz,l) = 0.0 + + ENDIF + + + ENDDO + + ENDIF + + RETURN + + END subroutine calczgr1d + +! ############################################################################## +! ############################################################################## +! +! Subroutine to correct number concentration to prevent reflectivity growth by +! sedimentation in 2-moment ZXX scheme. +! Calculation is in a slab (constant jgs) +! + + subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & + & z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, & + & lvol, rho_qx, infall, ixcol) + + + implicit none + + integer nx,ny,nz,nor,na,ngt,jgs,ixcol + + real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) ! sedimented N and q + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented reflectivity + real t1(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented N (by Vm) +! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt) + real z0(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! initial reflectivity + + real db(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer l ! index for q + integer ln ! index for N + integer lvol ! index for volume + real rho_qx + integer infall + + + integer ix,jy,kz + double precision vr,qr,nrx,rd,g1,zx,chw,z,znew,zt,zxt + real xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + + ndbz = 0 + nmwgt = 0 + nnwgt = 0 + nwlessthanz = 0 + + + + jy = jgs + ix = ixcol + + IF ( l .eq. lh .or. l .eq. lhl .or. ( l == lr .and. imurain == 1 ) ) THEN + + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & + & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) + + DO kz = 1,kze + + + IF ( t0(ix,jy,kz) .gt. 0. ) THEN ! { + + IF ( lvol .gt. 1 ) THEN + IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN + xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) + xdn = Min( 900., Max( hdnmn, xdn ) ) + ELSE + xdn = rho_qx + ENDIF + ELSE + xdn = rho_qx + ENDIF + + IF ( l == lr ) xdn = 1000. + + qr = a(ix,jy,kz,l) + xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + chw = a(ix,jy,kz,ln) + + IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN + xv = Min( xvmx, Max( xvmn,xv ) ) + chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + ENDIF + + zx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw + z = zx*(6./(pi*1000.))**2 + + + IF ( (z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & + & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN !{ + + zx = t0(ix,jy,kz)/((6./(pi*1000.))**2) + + nrx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/zx + IF ( infall .eq. 3 ) THEN + IF ( nrx .gt. a(ix,jy,kz,ln) ) THEN + ndbz = ndbz + 1 + IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) + ELSE + IF ( nrx .gt. a(ix,jy,kz,ln) .and. t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + IF ( nrx .lt. t1(ix,jy,kz) ) THEN + ndbz = ndbz + 1 + ELSE + nmwgt = nmwgt + 1 + IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 + ENDIF + ELSE + nnwgt = nnwgt + 1 + ENDIF + + a(ix,jy,kz,ln) = Max(Min( real(nrx), t1(ix,jy,kz) ), a(ix,jy,kz,ln) ) + ENDIF + + ELSE ! } { + IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN + IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + nmwgt = nmwgt + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + ENDIF + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + nrx = a(ix,jy,kz,ln) + + + + ENDIF ! } + + ! } + ELSE ! { + IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN + IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + nmwgt = nmwgt + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + ENDIF + ENDIF! } + + ENDDO + + + ELSEIF ( l .eq. lr .and. imurain == 3) THEN + + xdn = 1000. + + DO kz = 1,kze + IF ( t0(ix,jy,kz) .gt. 0. ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + z = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) + + IF ( z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & + & t0(ix,jy,kz) .gt. 0.0 & + & .and. t0(ix,jy,kz) .gt. z0(ix,kz,l) ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn) + chw = a(ix,jy,kz,ln) + nrx = 3.6*(rnu+2.0)*vr**2/((rnu+1.0)*t0(ix,jy,kz)) + IF ( infall .eq. 3 ) THEN + a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) + ELSEIF ( infall .eq. 4 ) THEN + a(ix,jy,kz,ln) = Max( Min( real(nrx), t1(ix,jy,kz)), a(ix,jy,kz,ln) ) + ENDIF + + ELSE + + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + + ENDIF + + ELSE + + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + + ENDIF + + + ENDDO + + ENDIF + + RETURN + + END subroutine calcnfromz1d + + +! ############################################################################## +! ############################################################################## +! +! Subroutine to calculate number concentrations from initial state that has only mixing ratio. +! N will be in #/kg, NOT #/m^3, since sedimentation is done next. +! + +! +! 10.27.2015: Added hail calculation +! + subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) + + + implicit none + + integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) + + real dn(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer lvol ! index for volume + integer infall + + + integer ix,jy,kz + double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision :: zr, zs, zh, dninv + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4 + real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 + real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) + real, parameter :: zhfac = 1./(pi*xdnh*xn0h) + real, parameter :: zrfac = 1./(pi*xdnr*xn0r) + real, parameter :: zsfac = 1./(pi*xdns*xn0s) + real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) + real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + + real xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + +! ------------------------------------------------------------------ + + + jy = 1 + + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + + g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + + IF ( imurain == 3 ) THEN + g1r = (rnu+2.0)/(rnu+1.0) + ELSE ! imurain == 1 + g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + ENDIF + + g1s = (snu+2.0)/(snu+1.0) + + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + dninv = 1./dn(ix,kz) + + ! Cloud droplets + + IF ( lnc > 1 ) THEN + IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + an(ix,jy,kz,lnc) = qccn + ENDIF + ENDIF + + ! Cloud ice + + IF ( lni > 1 ) THEN + IF ( an(ix,jy,kz,lni) <= 0.1*cxmin .and. an(ix,jy,kz,li) > qxmin(li) ) THEN + an(ix,jy,kz,lni) = an(ix,jy,kz,li)/xims + ENDIF + ENDIF + + ! rain + + IF ( lnr > 1 ) THEN + IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin(lr) ) THEN + + q = an(ix,jy,kz,lr) + + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input + + nrx = n1*g1r/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio + + ENDIF + ENDIF + + ! snow + IF ( lns > 1 ) THEN + IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin(ls) ) THEN + + q = an(ix,jy,kz,ls) + + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input + + nrx = n1*g1s/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio + + ENDIF + ENDIF + + ! graupel + + IF ( lnh > 1 ) THEN + IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN + IF ( lvh > 1 ) THEN + IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN + an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh + ENDIF + ENDIF + + q = an(ix,jy,kz,lh) + + laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input + + nrx = n1*g1h/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio + + ENDIF + ENDIF + + ! hail + + IF ( lnhl > 1 .and. lhl > 1 ) THEN + IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN + IF ( lvhl > 1 ) THEN + IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN + an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl + ENDIF + ENDIF + + q = an(ix,jy,kz,lhl) + + laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input + + nrx = n1*g1hl/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio + + ENDIF + ENDIF + + ENDDO ! ix + ENDDO ! kz + + RETURN + + END subroutine calcnfromq + +! ############################################################################## +! ############################################################################## +! +! Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio. +! N will be in #/kg, NOT #/m^3, since sedimentation is done next. +! + +! +! 10.27.2015: Added hail calculation +! + subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) + + + implicit none + + integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) from CUTEN arrays + real anold(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) + + real dn(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer lvol ! index for volume + integer infall + + + integer ix,jy,kz + double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision :: zr, zs, zh, dninv + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4 + real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 + real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) + real, parameter :: zhfac = 1./(pi*xdnh*xn0h) + real, parameter :: zrfac = 1./(pi*xdnr*xn0r) + real, parameter :: zsfac = 1./(pi*xdns*xn0s) + real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) + real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: xcms=1000.*0.523599*(2.*7.5e-6)**3 ! mks (100 micron diam solid sphere approx) + + real :: xmass,xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + +! ------------------------------------------------------------------ + + + jy = 1 + + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + + g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + + IF ( imurain == 3 ) THEN + g1r = (rnu+2.0)/(rnu+1.0) + ELSE ! imurain == 1 + g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + ENDIF + + g1s = (snu+2.0)/(snu+1.0) + + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + dninv = 1./dn(ix,kz) + + ! Cloud droplets + + IF ( lnc > 1 ) THEN +! IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + IF ( an(ix,jy,kz,lnc) > qxmin(lc) ) THEN + anold(ix,jy,kz,lnc) = anold(ix,jy,kz,lnc) + an(ix,jy,kz,lc)/xcms + ENDIF + ENDIF + + ! Cloud ice + + IF ( lni > 1 ) THEN + IF ( an(ix,jy,kz,lni) > qxmin(li) ) THEN + anold(ix,jy,kz,lni) = anold(ix,jy,kz,lni) + an(ix,jy,kz,li)/xims + ENDIF + ENDIF + + ! rain + + IF ( lnr > 1 ) THEN + IF ( an(ix,jy,kz,lr) > qxmin(lr) ) THEN ! adding rain mass from CU scheme + + IF ( .true. .or. (anold(ix,jy,kz,lr) - an(ix,jy,kz,lr)) < qxmin(lr) .or. anold(ix,jy,kz,lnr) < cxmin ) THEN + + q = an(ix,jy,kz,lr) + + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input + + nrx = n1*g1r/g0 ! number concentration for different shape parameter + + anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + nrx ! *dninv ! convert to number mixing ratio + + ELSE + ! assume mean particle mass of pre-existing snow + xmass = anold(ix,jy,kz,lr)/anold(ix,jy,kz,lnr) + anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass + ENDIF + + ENDIF + ENDIF + + ! snow + IF ( lns > 1 ) THEN + IF ( an(ix,jy,kz,ls) > qxmin(ls) ) THEN ! adding snow mass from CU scheme + + IF ( .true. .or. (anold(ix,jy,kz,ls) - an(ix,jy,kz,ls)) < qxmin(ls) .or. anold(ix,jy,kz,lns) < cxmin ) THEN + + ! assume that there was no snow before this + + q = an(ix,jy,kz,ls) + + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input + + nrx = n1*g1s/g0 ! number concentration for different shape parameter + + anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + nrx ! *dninv ! convert to number mixing ratio + + ELSE + ! assume mean particle mass of pre-existing snow + xmass = anold(ix,jy,kz,ls)/anold(ix,jy,kz,lns) + anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + an(ix,jy,kz,ls)/xmass + ENDIF + + ENDIF + ENDIF + + ! graupel + +! IF ( lnh > 1 ) THEN +! IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN +! IF ( lvh > 1 ) THEN +! IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN +! an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh +! ENDIF +! ENDIF +! +! q = an(ix,jy,kz,lh) +! +! laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope +! +! n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input +! +! nrx = n1*g1h/g0 ! number concentration for different shape parameter +! +! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio +! +! ENDIF +! ENDIF +! +! ! hail +! +! IF ( lnhl > 1 .and. lhl > 1 ) THEN +! IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN +! IF ( lvhl > 1 ) THEN +! IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN +! an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl +! ENDIF +! ENDIF +! +! q = an(ix,jy,kz,lhl) +! +! laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope +! +! n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input +! +! nrx = n1*g1hl/g0 ! number concentration for different shape parameter +! +! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio +! +! ENDIF +! ENDIF + + ENDDO ! ix + ENDDO ! kz + + RETURN + + END subroutine calcnfromcuten + +! ##################################################################### +! ##################################################################### + + SUBROUTINE calc_eff_radius & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,t1,t2,t3 & + & ,an,dn ) + + implicit none + + integer, parameter :: ng1 = 1 + integer :: nx,ny,nz,na + integer :: ng + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + + +! +! external temporary arrays +! + + real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + + + + ! local + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + +! +! declarations microphysics and for gather/scatter +! + integer nxmpb,nzmpb,nxz + integer mgs,ngs,numgs,inumgs + parameter (ngs=1) + integer ngscnt,igs(ngs),kgs(ngs) + real rho0(ngs) + + integer ix,kz,i,n, kp1 + integer :: jy, jgs + integer ixb,ixe,jyb,jye,kzb,kze + + integer itile,jtile,ktile + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + + real :: qx(ngs,lv:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: alpha(ngs,lc:lhab) + + real :: gamc1,gamc2,gami1,gami2,gams1,gams2, factor_c, factor_i, factor_s + real :: lam_c, lam_i, lam_s + integer :: il + + +! ------------------------------------------------------------------------------- + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + jy = 1 + pb(:) = 0.0 + pinit(:) = 0.0 + + gamc1 = Gamma_sp(2. + cnu) + gamc2 = 1. ! Gamma[1 + alphac] + gami1 = Gamma_sp(2. + cinu) + gami2 = 1. ! Gamma[1 + alphac] + gams1 = Gamma_sp(2. + snu) + gams2 = Gamma_sp(1. + snu) + + factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu) + factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu) + factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu) + +! +! jy = 1 ! working on a 2d slab +!! VERY IMPORTANT: SET jgs = jy + + jgs = jy + + mgs = 1 + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + rho0(mgs) = dn(ix,jy,kz) + DO il = lc,ls + qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) + cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) + ENDDO + + IF ( qx(mgs,lc) > qxmin(lc) ) THEN +! Lambda for cloud droplets + lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) + t1(ix,jy,kz) = 0.5*factor_c/lam_c + ENDIF + + IF ( qx(mgs,li) > qxmin(li) ) THEN +! Lambda for cloud ice + lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) + t2(ix,jy,kz) = 0.5*factor_i/lam_i + ENDIF + + IF ( qx(mgs,ls) > qxmin(ls) ) THEN +! Lambda for snow + lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.) + t3(ix,jy,kz) = 0.5*factor_s/lam_s + ENDIF + + + ENDDO ! ix + ENDDO ! kz + + RETURN + END SUBROUTINE calc_eff_radius + + +! ##################################################################### +! ##################################################################### + + SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & + & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt) + +!##################################################################### +! Purpose: find the amount of vapor that can be condensed to liquid +!##################################################################### + + implicit none + + integer ngs,mgs,ngscnt + + real theta2temp + + real qvex + + integer nqsat + real fqsat, cbw + + real ss1 ! 'target' supersaturation +! +! input arrays +! + real qv0(ngs), qcw1(ngscnt), pres(ngs), qwvp0(mgs) + real thetap0(ngs), theta0(ngs) + real fcqv1(ngs), felvcp(ngs), pi0(ngs) + real pk(ngs) + + real tabqvs(nqsat) +! +! Local stuff +! + + integer itertd + integer ltemq + real gamss + real theta(ngs), qvap(ngs), pqs(ngs), qcw(ngs), qwv(ngs) + real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs) + real dqcw(ngs), dqwv(ngs), dqvcnd(ngs) + real temg(ngs), temcg(ngs), thetap(ngs) + + real tfr + parameter ( tfr = 273.15 ) + +! real poo,cap +! parameter ( cap = rd/cp, poo = 1.0e+05 ) +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + pqs(mgs) = (380.0)/(pres(mgs)) + thetap(mgs) = thetap0(mgs) + theta(mgs) = thetap(mgs) + theta0(mgs) + qwvp(mgs) = qwvp0(mgs) + qvap(mgs) = max( (qwvp0(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) +! +! +! +! reset temporaries for cloud particles and vapor +! + + qwv(mgs) = max( 0.0, qvap(mgs) ) + qcw(mgs) = max( 0.0, qcw1(mgs) ) +! +! + qcwtmp(mgs) = qcw(mgs) + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) +! +! iterate adjustment +! + do itertd = 1,2 +! +! +! calculate super-saturation +! + dqcw(mgs) = 0.0 + dqwv(mgs) = ( qwv(mgs) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qcw(mgs) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qcw(mgs) + dqwv(mgs) = dqwv(mgs) + qcw(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) ) ! add to perturbation vapor +! + qcw(mgs) = qcw(mgs) + dqcw(mgs) + + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) ) + + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN +! + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) +! +! + dqcw(mgs) = dqvcnd(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) ) & + & / (pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qcw(mgs) = qcw(mgs) + dqcw(mgs) +! + END IF ! dqwv(mgs) .ge. 0. + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr +! tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qcw(mgs) = max( 0.0, qcw(mgs) ) + qwv(mgs) = max( 0.0, qvap(mgs)) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) + end do +! +! end the saturation adjustment iteration loop +! +! + qvex = Max(0.0, qcw(mgs) - qcw1(mgs) ) + + RETURN + END SUBROUTINE QVEXCESS + +! ##################################################################### +! ##################################################################### + + + + + +! +! ############################################################################## +! + SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & + & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & + & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + implicit none + + integer ngscnt,ngs0,ngs,nz +! integer infall ! whether to calculate number-weighted fall speeds + + real xv(ngs,lc:lhab) + real qx(ngs,lv:lhab) + real qxw(ngs,ls:lhab) + real cx(ngs,lc:lhab) + real vtxbar(ngs,lc:lhab,3) + real xmas(ngs,lc:lhab) + real xdn(ngs,lc:lhab) + real cdxgs(ngs,lc:lhab) + real xdia(ngs,lc:lhab,3) + real xvmn0(lc:lhab), xvmx0(lc:lhab) + real qxmin(lc:lhab) + real cdx(lc:lhab) + real alpha(ngs,lc:lhab) + + real rho0(ngs),rhovt(ngs),temcg(ngs) + real cno(lc:lhab) + real cnostmp(ngs) + + real cwc1, cimna, cimxa + real cnina(ngs) + integer kgs(ngs) + real fadvisc(ngs) + real fsw + + integer ipconc1 + integer ndebug1 + + integer, intent (in) :: itype1a,itype2a,infdo + integer, intent (in) :: ildo ! which species to do, or all if ildo=0 + + real :: axh(ngs),bxh(ngs) + real :: axhl(ngs),bxhl(ngs) + +! Local vars + + + + real swmasmx, dtmp + real cd + real cwc0 ! ,cwc1 + real :: cwch(ngscnt), cwchl(ngscnt) + real :: cwchtmp,cwchltmp,xnutmp + real pii + real cimasx,cimasn + real cwmasn,cwmasx,cwradn + real cwrad + real vr,rnux + real alp + + real ccimx + + integer mgs + + real arx,frx,vtrain,fw + real fwlo,fwhi,rfwdiff + real ar,br,cs,ds +! real gf4p5, gf4ds, gf4br, ifirst, gf1ds +! real gfcinu1, gfcinu1p47, gfcinu2p47 + real gr + real rwrad,rwdia + real mwfac + integer il + +! save gf4p5, gf4ds, gf4br, ifirst, gf1ds +! save gfcinu1, gfcinu1p47, gfcinu2p47 +! data ifirst /0/ + + real bta1,cnit + parameter ( bta1 = 0.6, cnit = 1.0e-02 ) + real x,y,tmp,del + real aax,bbx,delrho + integer :: indxr + real mwt, nwt, zwt + real, parameter :: rho00 = 1.225 + integer i + real xvbarmax + + integer l1, l2 + + +! +! set values +! +! cwmasn = 5.23e-13 ! radius of 5.0e-6 +! cwradn = 5.0e-6 +! cwmasx = 5.25e-10 ! radius of 50.0e-6 + + fwlo = 0.2 ! water fraction to start weighting toward rain fall speed + fwhi = 0.4 ! water fraction at which rain fall speed only is used + rfwdiff = 1./(fwhi - fwlo) + +! pi = 4.0*atan(1.0) + pii = piinv ! 1.0/pi + + arx = 10. + frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + + ar = 841.99666 + br = 0.8 + gr = 9.8 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab + ELSE + l1 = ildo + l2 = ildo + ENDIF + +! IF ( ifirst .eq. 0 ) THEN +! ifirst = 1 +! gf4br = gamma(4.0+br) +! gf4ds = gamma(4.0+ds) +!! gf1ds = gamma(1.0+ds) +! gf4p5 = gamma(4.0+0.5) +! gfcinu1 = gamma(cinu + 1.0) +! gfcinu1p47 = gamma(cinu + 1.47167) +! gfcinu2p47 = gamma(cinu + 2.47167) + + IF ( lh .gt. 1 ) THEN + IF ( dmuh == 1.0 ) THEN + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + ELSE + cwchtmp = 6.0*pii*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) + ENDIF + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) + ELSE + cwchltmp = 6.0*pii*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) + ENDIF + ENDIF + + IF ( ipconc .le. 5 ) THEN + IF ( lh .gt. 1 ) cwch(:) = cwchtmp + IF ( lhl .gt. 1 ) cwchl(:) = cwchltmp + ELSE + DO mgs = 1,ngscnt + + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( dmuh == 1.0 ) THEN + cwch(mgs) = ((3. + alpha(mgs,lh))*(2. + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lh) - 2.0)/3.0 + cwch(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1.)/xmu(lh) )/gamma_sp( (xnutmp + 2.)/xmu(lh) ) + ENDIF + ELSE + cwch(mgs) = cwchtmp + ENDIF + ENDIF + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchl(mgs) = ((3. + alpha(mgs,lhl))*(2. + alpha(mgs,lhl))*(1.0 + alpha(mgs,lhl)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lhl) - 2.0)/3.0 + cwchl(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1)/xmu(lhl) )/gamma_sp( (xnutmp + 2)/xmu(lhl) ) + ENDIF + ELSE + cwchl(mgs) = cwchltmp + ENDIF + ENDIF + + ENDDO + + ENDIF + + + cimasn = Min( cimas0, 6.88e-13) + cimasx = 1.0e-8 + ccimx = 5000.0e3 ! max of 5000 per liter + + cwc1 = 6.0/(pi*1000.) + cwc0 = pii ! 6.0*pii + mwfac = 6.0**(1./3.) + + + if (ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set scale diameter' +! + + +! +! cloud water variables +! ################################################################ +! +! DROPLETS +! +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cloud water variables' + + IF ( ildo == 0 .or. ildo == lc ) THEN + + do mgs = 1,ngscnt + xv(mgs,lc) = 0.0 + + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN !{ + + IF ( ipconc .ge. 2 ) THEN + IF ( cx(mgs,lc) .gt. cxmin) THEN !{ + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = Min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ENDIF + ELSE + IF ( ipconc .lt. 2 ) THEN + cx(mgs,lc) = rho0(mgs)*ccn/rho00 ! scales to local density, relative to standard air density + ENDIF + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN !{ + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & + & xdn(mgs,lc)*xvmx(lc) ) + + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 1.0e-9 ) THEN + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN + xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSE + xmas(mgs,lc) = cwmasn + xv(mgs,lc) = xmas(mgs,lc)/1000. +! do not define ccw here! it can feed back to ccn!!! cx(mgs,lc) = 0.0 ! cwnc(mgs) + ENDIF !} + ENDIF !} +! IF ( ipconc .lt. 2 ) THEN +! xmas(mgs,lc) = & +! & min( max(qx(mgs,lc)*rho0(mgs)/cwnc(mgs),cwmasn),cwmasx ) +! cx(mgs,lc) = Max(1.0,qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)) +! ELSE +! cwnc(mgs) = an(igs(mgs),jgs,kgs(mgs),lnc) +! cx(mgs,lc) = cwnc(mgs) +! ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**(1./3.) + xdia(mgs,lc,2) = xdia(mgs,lc,1)**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + cwrad = 0.5*xdia(mgs,lc,1) + IF ( fadvisc(mgs) > 0.0 ) THEN + vtxbar(mgs,lc,1) = & + & (2.0*gr*xdn(mgs,lc) *(cwrad**2)) & + & /(9.0*fadvisc(mgs)) + ELSE + vtxbar(mgs,lc,1) = 0.0 + ENDIF + + + ELSE + xmas(mgs,lc) = cwmasn + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + IF ( qx(mgs,lc) <= 0.0 ) cx(mgs,lc) = 0.0 + IF ( ipconc .le. 1 ) cx(mgs,lc) = 0.01 + xdia(mgs,lc,1) = 2.*cwradn + xdia(mgs,lc,2) = 4.*cwradn**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + vtxbar(mgs,lc,1) = 0.0 + + ENDIF !} qcw .gt. qxmin(lc) + + end do + + ENDIF + + + +! +! cloud ice variables +! columns +! +! ################################################################ +! +! CLOUD ICE +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cip' + + IF ( li .gt. 1 .and. ( ildo == 0 .or. ildo == li ) ) THEN + do mgs = 1,ngscnt + xdn(mgs,li) = 900.0 + IF ( ipconc .eq. 0 ) THEN +! cx(mgs,li) = min(cnit*exp(-temcg(mgs)*bta1),1.e+09) + cx(mgs,li) = cnina(mgs) + IF ( cimna .gt. 1.0 ) THEN + cx(mgs,li) = Max(cimna,cx(mgs,li)) + ENDIF + IF ( cimxa .gt. 1.0 ) THEN + cx(mgs,li) = Min(cimxa,cx(mgs,li)) + ENDIF +! erm 3/28/2002 + IF ( itype1a .ge. 1 .or. itype2a .ge. 1 ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) + ENDIF +! + cx(mgs,li) = max(1.0e-20,cx(mgs,li)) +! cx(mgs,li) = Min(ccimx, cx(mgs,li)) + + + ELSEIF ( ipconc .ge. 1 ) THEN + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) +! cx(mgs,li) = Max(1.0,cx(mgs,li)) + ENDIF + ENDIF + + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + xmas(mgs,li) = & + & max( qx(mgs,li)*rho0(mgs)/cx(mgs,li), cimasn ) +! & min( max(qx(mgs,li)*rho0(mgs)/cx(mgs,li),cimasn),cimasx ) + +! if ( temcg(mgs) .gt. 0.0 ) then +! xdia(mgs,li,1) = 0.0 +! else + if ( xmas(mgs,li) .gt. 0.0 ) THEN ! cimasn ) then +!c xdia(mgs,li,1) = 0.4892*(xmas(mgs,li)**(0.4554)) +! xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + +! xdia(mgs,li,1) = (132.694*5.40662/xmas(mgs,li))**(-1./2.9163) ! for inverse exponential distribution + IF ( ixtaltype == 1 ) THEN ! column + xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + xdia(mgs,li,3) = 0.1871*(xmas(mgs,li)**(0.3429)) + ELSEIF ( ixtaltype == 2 ) THEN ! disk + xdia(mgs,li,1) = 0.277823*xmas(mgs,li)**0.359971 + xdia(mgs,li,3) = 0.277823*xmas(mgs,li)**0.359971 + ENDIF + end if +! end if +! xdia(mgs,li,1) = max(xdia(mgs,li,1), 5.e-6) +! xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + + IF ( ipconc .ge. 0 ) THEN +! vtxbar(mgs,li,1) = rhovt(mgs)*49420.*40.0005/5.40662*xdia(mgs,li,1)**(1.415) ! mass-weighted +! vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + IF ( icefallopt == 1 ) THEN ! default ice fall + IF ( ixtaltype == 1 ) THEN ! column + tmp = (67056.6300748612*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p47 + vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + ELSEIF ( ixtaltype == 2 ) THEN ! disk -- but just use Ferrier (1994) snow fall speeds for now + vtxbar(mgs,li,1) = 11.9495*rhovt(mgs)*(xv(mgs,li))**(0.14) + vtxbar(mgs,li,2) = 7.02909*rhovt(mgs)*(xv(mgs,li))**(0.14) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ENDIF + + ELSEIF ( icefallopt == 2 ) THEN ! ! Ferrier ice fall speed + tmp = (82.3166*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.22117*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p22 + vtxbar(mgs,li,1) = tmp*gfcinu2p22/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ELSEIF ( icefallopt == 3 ) THEN ! ! Adjusted Ferrier (smaller exponent of 0.55 instead of 0.6635) + + tmp = (47.6273*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.18333*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p18 + vtxbar(mgs,li,1) = tmp*gfcinu2p18/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ENDIF +! vtxbar(mgs,li,1) = vtxbar(mgs,li,2)*(1.+cinu)/(1. + cinu) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) +! xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 +! vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + ELSE + xdia(mgs,li,1) = max(xdia(mgs,li,1), 10.e-6) + xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) + xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 + vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + ENDIF ! ipconc gt 3 + ELSE + xmas(mgs,li) = 1.e-13 + IF ( qx(mgs,li) <= 0.0 ) cx(mgs,li) = 0.0 + xdn(mgs,li) = 900.0 + xdia(mgs,li,1) = 1.e-7 + xdia(mgs,li,2) = (1.e-14) + xdia(mgs,li,3) = 1.e-7 + vtxbar(mgs,li,1) = 0.0 +! cicap(mgs) = 0.0 +! ciat(mgs) = 0.0 + ENDIF + + IF ( icefallfac /= 1.0 ) THEN + vtxbar(mgs,li,1) = icefallfac*vtxbar(mgs,li,1) + vtxbar(mgs,li,2) = icefallfac*vtxbar(mgs,li,2) + vtxbar(mgs,li,3) = icefallfac*vtxbar(mgs,li,3) + ENDIF + + + + end do + + ENDIF ! li .gt. 1 + + +! ################################################################ +! +! RAIN +! + +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + +! IF ( qx(mgs,lr) .gt. 10.0e-3 ) & +! & write(0,*) 'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr) + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + xvbarmax = xvmx(lr) + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(lr) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ENDIF + + IF ( xv(mgs,lr) .gt. xvbarmax ) THEN + xv(mgs,lr) = xvbarmax + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) + IF ( imurain == 3 ) THEN +! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) + xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) + ELSE ! imurain == 1, Characteristic diameter (1/lambda) + xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + ENDIF +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + +! Inverse exponential version: +! xdia(mgs,lr,1) = +! & (qx(mgs,lr)*rho0(mgs) +! & /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) + ELSE + xdia(mgs,lr,1) = & + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) + cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + end if + else + xdia(mgs,lr,1) = 1.e-9 + xdia(mgs,lr,3) = 1.e-9 + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + end if + xdia(mgs,lr,2) = xdia(mgs,lr,1)**2 +! xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 + end do + + ENDIF +! ################################################################ +! +! SNOW +! + + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + if ( ipconc .ge. 4 ) then ! + + xmas(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(Max(1.0e-9,cx(mgs,ls))) + swmasmx = 13.7e-6 +! IF ( xmas(mgs,ls) > swmasmx ) THEN +! xmas(mgs,ls) = swmasmx +! cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) +! ENDIF + + IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship + + xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) + xdn(mgs,ls) = Max( 100.0, xdn(mgs,ls) ) ! limit snow to 100. to keep other equations in line + + IF ( xdn(mgs,ls) <= 900. ) THEN + dtmp = Sqrt( xmas(mgs,ls)/0.069 ) ! diameter (meters) of mean mass particle using Cox 1998 relation (m = p d^2) + xv(mgs,ls) = 28.8887*xmas(mgs,ls)**(3./2.) + ELSE ! at small sizes, assume ice spheres + xdn(mgs,ls) = 900. + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) + dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + ELSE ! leave xdn(ls) at default value + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) + dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + xdia(mgs,ls,1) = dtmp ! (xv(mgs,ls)*cwc0*6.0)**(1./3.) + + IF ( xv(mgs,ls) .lt. xvmn(ls) .and. isnowdens == 1) THEN + xv(mgs,ls) = Max( xvmn(ls),xv(mgs,ls) ) + xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls) + cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + IF ( xv(mgs,ls) .gt. xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN + xv(mgs,ls) = Min( xvmx(ls), Max( xvmn(ls),xv(mgs,ls) ) ) + xmas(mgs,ls) = 0.106214*xv(mgs,ls)**(2./3.) + cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) + xdia(mgs,ls,1) = Sqrt( xmas(mgs,ls)/0.069 ) + ENDIF + + xdia(mgs,ls,3) = xdia(mgs,ls,1) + + ELSE + xdia(mgs,ls,1) = & + & (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25) + cx(mgs,ls) = cnostmp(mgs)*xdia(mgs,ls,1) + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + xdia(mgs,ls,3) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + end if + else + xdia(mgs,ls,1) = 1.e-9 + xdia(mgs,ls,3) = 1.e-9 + cx(mgs,ls) = 0.0 + + IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship + xdn(mgs,ls) = 90. + ENDIF + + end if + xdia(mgs,ls,2) = xdia(mgs,ls,1)**2 +! swdia3(mgs) = xdia(mgs,ls,2)*xdia(mgs,ls,1) +! xmas(mgs,ls) = xdn(mgs,ls)*(pi/6.)*swdia3(mgs) + end do + + ENDIF ! ls .gt 1 +! +! +! ################################################################ +! +! GRAUPEL +! + + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + if ( ipconc .ge. 5 ) then + + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*Max(1.0e-9,cx(mgs,lh))) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) + + IF ( xv(mgs,lh) .lt. xvmn(lh) .or. xv(mgs,lh) .gt. xvmx(lh) ) THEN + xv(mgs,lh) = Min( xvmx(lh), Max( xvmn(lh),xv(mgs,lh) ) ) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) + cx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xmas(mgs,lh)) + ENDIF + + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*pii)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuh == 1.0 ) THEN + xdia(mgs,lh,1) = cwch(mgs)*xdia(mgs,lh,3) + ELSE + xdia(mgs,lh,1) = (xv(mgs,lh)*cwch(mgs))**(1./3.) + ENDIF + + ELSE + xdia(mgs,lh,1) = & + & (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25) + cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) + xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) + xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + else + xdia(mgs,lh,1) = 1.e-9 + xdia(mgs,lh,3) = 1.e-9 + end if + xdia(mgs,lh,2) = xdia(mgs,lh,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + + ENDIF + +! +! ################################################################ +! +! HAIL +! + + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then + if ( ipconc .ge. 5 ) then + + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*Max(1.0e-9,cx(mgs,lhl))) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xmas(mgs,lhl),qx(mgs,lhl) + + IF ( xv(mgs,lhl) .lt. xvmn(lhl) .or. xv(mgs,lhl) .gt. xvmx(lhl) ) THEN + xv(mgs,lhl) = Min( xvmx(lhl), Max( xvmn(lhl),xv(mgs,lhl) ) ) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) + cx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xmas(mgs,lhl)) + ENDIF + + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuhl == 1.0 ) THEN + xdia(mgs,lhl,1) = cwchl(mgs)*xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = (xv(mgs,lhl)*cwchl(mgs))**(1./3.) + ENDIF + +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = & + & (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25) + cx(mgs,lhl) = cno(lhl)*xdia(mgs,lhl,1) + xv(mgs,lhl) = Max(xvmn(lhl), rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ) + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) + end if + else + xdia(mgs,lhl,1) = 1.e-9 + xdia(mgs,lhl,3) = 1.e-9 + end if + xdia(mgs,lhl,2) = xdia(mgs,lhl,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + + ENDIF +! +! +! +! Set terminal velocities... +! also set drag coefficients (moved to start of subroutine) +! +! cdx(lr) = 0.60 +! cdx(lh) = 0.45 +! cdx(lhl) = 0.45 +! cdx(lf) = 0.45 +! cdx(lgh) = 0.60 +! cdx(lgm) = 0.80 +! cdx(lgl) = 0.80 +! cdx(lir) = 2.00 +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set terminal velocities' +! +! +! ################################################################ +! +! RAIN +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + IF ( ipconc .lt. 3 ) THEN + vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs) +! write(91,*) 'vtxbar: ',vtxbar(mgs,lr,1),mgs,gf4br,xdia(mgs,lr,1),rhovt(mgs) + ELSE + + IF ( imurain == 1 ) THEN ! DSD of Diameter + + ! using functional form of arx*(1 - Exp(-frx*diameter) ), with arx = arx = 10. + ! and frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + ! Similar form as in Atlas et al. (1973), who had 9.65 - 10.3*Exp[-600 * d] + + + alp = alpha(mgs,lr) + + vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted + + IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ! number weighted + ELSE + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + + IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ! z-weighted + ELSE + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + +! write(91,*) 'setvt: alp,vn,vm,vz = ',alp,vtxbar(mgs,lr,2), vtxbar(mgs,lr,1), vtxbar(mgs,lr,3),alpha(mgs,lr) + + ELSEIF ( imurain == 3 ) THEN ! DSD of Volume + + IF ( lzr < 1 ) THEN ! not 3-moment rain + rwdia = Min( xdia(mgs,lr,1), 8.0e-3 ) + + vtxbar(mgs,lr,1) = rhovt(mgs)*6.0*pii*( 0.04771 + 3788.0*rwdia - & + & 1.105e6*rwdia**2 + 1.412e8*rwdia**3 - 6.527e9*rwdia**4) + + IF ( infdo .ge. 1 ) THEN + IF ( rssflg >= 1 ) THEN + vtxbar(mgs,lr,2) = (0.09112 + 2714.0*rwdia - 4.872e5*rwdia**2 + & + & 4.495e7*rwdia**3 - 1.626e9*rwdia**4)*rhovt(mgs) + ELSE + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + ENDIF + + IF ( infdo .ge. 2 ) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)*( & + & 0.0911229 + & + & 9246.494*(rwdia) - & + & 3.2839926e6*(rwdia**2) + & + & 4.944093e8*(rwdia**3) - & + & 2.631718e10*(rwdia**4) ) + ENDIF + + ELSE ! 3-moment rain, gamma-volume + + vr = xv(mgs,lr) + rnux = alpha(mgs,lr) + + IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag + vtxbar(mgs,lr,2) = rhovt(mgs)* & + & (((1. + rnux)/vr)**(-1.333333)* & + & (0.0911229*((1. + rnux)/vr)**1.333333*Gamma_sp(1. + rnux) + & + & (5430.3131*(1. + rnux)*Gamma_sp(4./3. + rnux))/ & + & vr - 1.0732802e6*((1. + rnux)/vr)**0.6666667* & + & Gamma_sp(1.666667 + rnux) + & + & 8.584110982429507e7*((1. + rnux)/vr)**(1./3.)* & + & Gamma_sp(2. + rnux) - & + & 2.3303765697228556e9*Gamma_sp(7./3. + rnux)))/ & + & Gamma_sp(1. + rnux) + ENDIF + +! mass-weighted + vtxbar(mgs,lr,1) = rhovt(mgs)* & + & (0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(2. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma_sp(2.333333333333333 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666*vr**0.6666666666666666* & + & Gamma_sp(2.6666666666666667 + rnux) + & + & 8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(3 + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma_sp(3.333333333333333 + rnux))/ & + & ((1 + rnux)**2.333333333333333*Gamma_sp(1 + rnux)) + + IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + + IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)* & + & ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(3. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma_sp(3.3333333333333335 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666* & + & vr**0.6666666666666666*Gamma_sp(3.6666666666666665 + rnux) + & + & 8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(4. + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma_sp(4.333333333333333 + rnux)))/ & + & ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma_sp(1 + rnux)) + +! write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) + + ELSEIF (infdo .ge. 2) THEN ! No size-sorting, set Z-weighted fall speed to mass-weighted + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + + + ENDIF + ENDIF ! imurain + +! IF ( rwrad*mwfac .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,1) = 20.1*Sqrt(100.*rwrad*mwfac)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,1) = 80.0e2*rwrad*rhovt(mgs)*mwfac +! ENDIF +! IF ( rwrad .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,2) = 20.1*Sqrt(100.*rwrad)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,2) = 80.0e2*rwrad*rhovt(mgs) +! ENDIF + ENDIF ! ipconc + else ! qr < qrmin + vtxbar(mgs,lr,1) = 0.0 + vtxbar(mgs,lr,2) = 0.0 + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set rain vt' + + ENDIF +! +! ################################################################ +! +! SNOW !Zrnic et al. (1993) +! + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + IF ( ipconc .ge. 4 ) THEN + if ( mixedphase .and. qsvtmod ) then + else + IF ( isnowfall == 1 ) THEN + ! original (Zrnic et al. 1993) + vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + IF ( isnowdens == 1 ) THEN + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14) + ELSE + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) + ENDIF + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,1) = 50.092*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + + IF(Abs(sssflg) >= 1) THEN + IF ( isnowfall == 1 ) THEN + vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + IF ( isnowdens == 1 ) THEN + vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1) + ELSE + vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1) + ENDIF + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,2) = 21.6147*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + ELSE + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDIF + IF ( infdo >= 2 ) THEN + IF ( isnowfall == 1 ) THEN + vtxbar(mgs,ls,3) = 6.12217*rhovt(mgs)*(xv(mgs,ls))**(1./12.) ! Zrnic et al 93 + ELSEIF ( isnowfall == 2 ) THEN + vtxbar(mgs,ls,3) = 13.3436*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! Ferrier 94 + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,3) = 61.0914*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + ENDIF + + IF ( sssflg < 0 .and. temcg(mgs) > Abs(sssflg) ) THEN ! above a given temperature, effectively turn off size sorting + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1) + ENDIF + + endif + ELSE ! single-moment: + vtxbar(mgs,ls,1) = (cs*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDIF + else + vtxbar(mgs,ls,1) = 0.0 + end if + + IF ( snowfallfac /= 1.0 ) THEN + vtxbar(mgs,ls,1) = snowfallfac*vtxbar(mgs,ls,1) + vtxbar(mgs,ls,2) = snowfallfac*vtxbar(mgs,ls,2) + vtxbar(mgs,ls,3) = snowfallfac*vtxbar(mgs,ls,3) + ENDIF + + + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set snow vt' + + ENDIF ! ls .gt. 1 +! +! +! ################################################################ +! +! GRAUPEL !Wisner et al. (1972) +! + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + + do mgs = 1,ngscnt + vtxbar(mgs,lh,1) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + cd = cdx(lh) + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lh)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axh(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxh(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + + + ELSE + axh(mgs) = mmgraupvt(indxr,2) + bxh(mgs) = mmgraupvt(indxr,3) + ENDIF + + aax = axh(mgs) + bbx = bxh(mgs) + + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + + ELSEIF ( icdx <= 0 ) THEN ! + aax = ax(lh) + bbx = bx(lh) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSE + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ENDIF + + cdxgs(mgs,lh) = cd + IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN +! axh(mgs) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lh)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + axh(mgs) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + bxh(mgs) = 0.5 + vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axh(mgs) * Sqrt(xdia(mgs,lh,1)) +! vtxbar(mgs,lh,1) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + ELSE + IF ( icdx /= 6 ) bbx = bx(lh) + tmp = 4. + alpha(mgs,lh) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 4. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! aax = Max( 1.0, Min(2.0, (xdn(mgs,lh)/400.) ) ) +! vtxbar(mgs,lh,1) = rhovt(mgs)*aax*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + + IF ( icdx > 0 .and. icdx /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y + axh(mgs) = aax + bxh(mgs) = bbx + ELSEIF (icdx == 6 ) THEN + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y + ELSE ! icdx < 0 + axh(mgs) = ax(lh) + bxh(mgs) = bx(lh) + vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + ENDIF + +! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) + ENDIF + + IF ( lwsm6 .and. ipconc == 0 ) THEN +! vtxbar(mgs,lh,1) = (330.*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs) + ENDIF + + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lh .gt. 1 +! +! +! ################################################################ +! +! HAIL +! + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + vtxbar(mgs,lhl,1) = 0.0 + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then + + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lhl)/rho_qh)**(2./3.) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lhl)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axhl(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxhl(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + + + ELSE + axhl(mgs) = mmgraupvt(indxr,2) + bxhl(mgs) = mmgraupvt(indxr,3) + ENDIF + + aax = axhl(mgs) + bbx = bxhl(mgs) + + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + + ELSE +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) +! cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ENDIF + + cdxgs(mgs,lhl) = cd + + IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 .and. icdxhl /= 6) THEN +! axhl(mgs) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lhl)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + axhl(mgs) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + bxhl(mgs) = 0.5 + vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axhl(mgs) * Sqrt(xdia(mgs,lhl,1)) + ELSE + IF ( icdxhl /= 6 ) bbx = bx(lhl) + tmp = 4. + alpha(mgs,lhl) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 4. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( icdxhl > 0 .and. icdxhl /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y + axhl(mgs) = aax + bxhl(mgs) = bbx + ELSEIF ( icdxhl == 6 ) THEN + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y + ELSE + axhl(mgs) = ax(lhl) + bxhl(mgs) = bx(lhl) + vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y + ENDIF + +! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) + ENDIF + + + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lhl .gt. 1 + + + IF ( infdo .ge. 1 ) THEN + +! DO il = lc,lhab +! IF ( il .ne. lr ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + IF ( li .gt. 1 ) THEN +! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) +! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) + +! test print stuff... +! IF ( xdia(mgs,li,1) .gt. 200.e-6 ) THEN +! tmp = (xv(mgs,li)*cwc0)**(1./3.) +! x = rhovt(mgs)*49420.*40.0005/5.40662*tmp**(1.415) +! y = rhovt(mgs)*49420.*1.25447*tmp**(1.415) +! write(6,*) 'Ice fall: ',vtxbar(mgs,li,1),x,y,tmp,xdia(mgs,li,1) +! ENDIF + ENDIF +! vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDDO + + IF ( lg .gt. lr ) THEN + + DO il = lg,lhab + IF ( ildo == 0 .or. ildo == il ) THEN + + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN ! DTD: added flag for size-sorting + + ! DTD: allow for setting of number-weighted and z-weighted fall speeds to the mass-weighted value, + ! effectively turning off size-sorting + + IF ( il .eq. lh ) THEN ! { + + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axh(mgs) + bbx = bxh(mgs) + ELSEIF ( icdx <= 0 ) THEN ! + aax = ax(lh) + bbx = bx(lh) + ENDIF + + ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN + + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl == 5 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) + cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axhl(mgs) + bbx = bxhl(mgs) + ENDIF + + ENDIF ! } + + IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and. & + ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! { + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cd*rho0(mgs)) ) + + ELSE + IF ( il == lh .and. icdx /= 6 ) bbx = bx(il) + IF ( il == lhl .and. icdxhl /= 6 ) bbx = bx(il) + tmp = 1. + alpha(mgs,il) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + alpha(mgs,il) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( il .eq. lh .or. il .eq. lhl) THEN ! { + IF ( ( il==lh .and. icdx > 0 ) ) THEN + IF ( icdx /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y + ELSE ! (icdx == 6 ) THEN + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF + + ELSEIF ( ( il==lhl .and. icdxhl > 0 ) ) THEN + IF ( icdxhl /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y + ELSE ! ( icdxhl == 6 ) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF + ELSE ! get here if il==lh and icdx < 0 -- or -- il==lhl and icdxhl < 0 + aax = ax(il) + vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y + ENDIF + +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* & +! & x)/y +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(ax(il)*xdia(mgs,il,1)**bx(il)* & +! & x)/y + IF ( infdo .ge. 2 ) THEN ! Z-weighted + + tmp = 7. + alpha(mgs,il) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 7. + alpha(mgs,il) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(xdia(mgs,il,1) )**bbx * & + & x)/y +! & Gamma(7.0 + alpha(mgs,il) + bbx))/Gamma(7. + alpha(mgs,il)) + IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & + .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN + write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y + ! call commasmpi_abort() + ENDIF +! & (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt3' + + ELSE ! hail + vtxbar(mgs,il,2) = & + & rhovt(mgs)*(ax(il)*xdia(mgs,il,1)**bx(il)* & + & x)/y + + IF ( infdo .ge. 2 ) THEN ! Z-weighted + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(1.0/xdia(mgs,il,1) )**(- bbx)* & + & Gamma_sp(7.0 + alpha(mgs,il) + bbx))/Gamma_sp(7. + alpha(mgs,il)) +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt4' + + ENDIF ! } +! & Gamma_sp(1.0 + dnu(il) + 0.6)/Gamma_sp(1. + dnu(il)) + ENDIF ! } + +! IF ( infdo .ge. 2 ) THEN ! Z-weighted +! vtxbar(mgs,il,3) = rhovt(mgs)* & +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) +! ENDIF + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'setvt: ',qx(mgs,il),xdia(mgs,il,1),xdia(mgs,il,3),dnu(il),ax(il),bx(il) +! ENDIF + ELSEIF ( (il .eq. lh .and. hssflg == 0) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 0) ) THEN ! no size-sorting for graupel or hail + vtxbar(mgs,il,2) = vtxbar(mgs,il,1) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) + ELSE ! not lh or lhl + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cdx(il)*rho0(mgs)) ) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5' + + + ENDIF + ELSE ! qx < qxmin + vtxbar(mgs,il,2) = 0.0 + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt6' + + ENDIF + ENDDO ! mgs + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt7' + + ENDIF + ENDDO ! il + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt8' + + ENDIF ! lg .gt. 1 + +! ENDIF +! ENDDO + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt9' + +! DO mgs = 1,ngscnt +! IF ( qx(mgs,lr) > qxmin(lr) ) THEN +! write(0,*) 'setvt2: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) +! ENDIF +! ENDDO + + ENDIF ! infdo .ge. 1 + + IF ( lh > 0 .and. graupelfallfac /= 1.0 ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lh,1) = graupelfallfac*vtxbar(mgs,lh,1) + vtxbar(mgs,lh,2) = graupelfallfac*vtxbar(mgs,lh,2) + vtxbar(mgs,lh,3) = graupelfallfac*vtxbar(mgs,lh,3) + axh(mgs) = graupelfallfac*axh(mgs) + ENDDO + ENDIF + + IF ( lhl > 0 .and. hailfallfac /= 1.0 ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lhl,1) = hailfallfac*vtxbar(mgs,lhl,1) + vtxbar(mgs,lhl,2) = hailfallfac*vtxbar(mgs,lhl,2) + vtxbar(mgs,lhl,3) = hailfallfac*vtxbar(mgs,lhl,3) + axhl(mgs) = hailfallfac*axhl(mgs) + ENDDO + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: END OF ROUTINE' + +!############ SETVTZ ############################ + + RETURN + END SUBROUTINE setvtz +!-------------------------------------------------------------------------- + +! +! ############################################################################## + +! +! subroutine to calculate fall speeds of hydrometeors +! + + subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & + & xvt, rhovtzx, & + & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,ildo,timesetvt) + +! 12.16.2005: .F version use in transitional SWM model +! +! 10.10.2003: Added cimn and cimx to setting for cci and cip. +! +! TO DO LIST: +! +! need to set up values for: +! : cipdia,cidia,cwdia,cwmas,vtwbar, +! : rho0,temcg,cip,cci +! +! and need to put fallspeed values in cwvt etc. +! + + implicit none + integer ng1 + parameter(ng1 = 1) + + integer, intent(in) :: ixcol ! which column to return + integer, intent(in) :: ildo + + integer nx,ny,nz,nor,norz,ngt,jgs,na + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real dn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real dtp,dtz1 + + real :: rhovtzx(nz,nx) + + integer ndebugzf + parameter (ndebugzf = 0) + + integer ix,jy,kz,i,j,k,il + integer infdo +! +! + real xvt(nz+1,nx,3,lc:lhab) ! 1=mass-weighted, 2=number-weighted + + real qxmin(lc:lhab) + real xdn0(lc:lhab) + real xvmn(lc:lhab), xvmx(lc:lhab) + double precision,optional :: timesetvt + + integer :: ngs + integer :: ngscnt,mgs,ipconc0 +! parameter ( ngs=200 ) + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: cdxgs(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + +! +! drag coefficients +! + real cdx(lc:lhab) +! +! Fixed intercept values for single moment scheme +! + real cno(lc:lhab) + + real cwccn0,cwmasn,cwmasx,cwradn +! real cwc0 + + integer nxmpb,nzmpb,nxz,numgs,inumgs + integer kstag + parameter (kstag=1) + + integer igs(ngs),kgs(ngs) + + real rho0(ngs),temcg(ngs) + + real temg(ngs) + + real rhovt(ngs) + + real cwnc(ngs),cinc(ngs) + real fadvisc(ngs),cwdia(ngs),cipmas(ngs) + +! real cimasn,cimasx, + real :: cnina(ngs),cimas(ngs) + + real :: cnostmp(ngs) + +! real pii +! +! +! general constants for microphysics +! + +! +! Miscellaneous +! + + logical flag + logical ldoliq + + + real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp + + real vtmax + real xvbarmax + + integer l1, l2 + + double precision :: dpt1, dpt2 + + +!----------------------------------------------------------------------------- +! MPI LOCAL VARIABLES + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + + logical :: debug_mpi = .false. + + + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: ENTERED SUBROUTINE" + +! ##################################################################### +! BEGIN EXECUTABLE +! ##################################################################### +! + +! constants +! + + ldoliq = .false. + IF ( ls .gt. 1 ) THEN + DO il = ls,lhab + ldoliq = ldoliq .or. ( lliq(il) .gt. 1 ) + ENDDO + ENDIF + +! poo = 1.0e+05 +! cp608 = 0.608 +! cp = 1004.0 +! cv = 717.0 +! dnz00 = 1.225 +! rho00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds +! cs = 12.42 +! ds = 0.42 +! pi = 4.0*atan(1.0) +! pii = piinv ! 1./pi +! pid4 = pi/4.0 +! qccrit = 2.0e-03 +! qscrit = 6.0e-04 +! cwc0 = pii + +! +! +! general constants for microphysics +! + +! +! ci constants in mks units +! +! cimasn = 6.88e-13 +! cimasx = 1.0e-8 +! +! Set terminal velocities... +! also set drag coefficients +! + jy = jgs + nxmpb = ixcol + nzmpb = 1 + nxz = 1*nz +! ngs = nz + numgs = 1 + + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab + ELSE + l1 = ildo + l2 = ildo + ENDIF + + + do inumgs = 1,numgs + ngscnt = 0 + + + do kz = nzmpb,nz + do ix = ixcol,ixcol + flag = .false. + + + DO il = l1,l2 + flag = flag .or. ( an(ix,jy,kz,il) .gt. qxmin(il) ) + ENDDO + + if ( flag ) then +! load temp quantities + + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if + end do !!ix + nxmpb = 1 + end do !! kz + +! if ( jy .eq. (ny-jstag) ) iend = 1 + + 1100 continue + + if ( ngscnt .eq. 0 ) go to 9998 +! +! set temporaries for microphysics variables +! + + +! +! Reconstruct various quantities +! + do mgs = 1,ngscnt + + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhovt(mgs) = rhovtzx(kgs(mgs),ixcol) ! Sqrt(rho00/rho0(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + + +! + end do +! +! only need fadvisc for + IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) + end do + ENDIF + + IF ( ipconc .eq. 0 ) THEN + do mgs = 1,ngscnt + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + end do + ENDIF + + + IF ( ildo > 0 ) THEN + vtxbar(:,ildo,:) = 0.0 + ELSE + vtxbar(:,:,:) = 0.0 + ENDIF + +! do mgs = 1,ngscnt +! qx(mgs,lv) = max(an(igs(mgs),jy,kgs(mgs),lv), 0.0) +! ENDDO + DO il = l1,l2 + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + end do + + cnostmp(:) = cno(ls) + IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF + + +! +! set concentrations +! + cx(:,:) = 0.0 + + if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + end do + end if + if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) +! IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! ELSE +! cx(mgs,lr) = Max( 0.0, cx(mgs,lr) ) +! ENDIF + end do + end if + if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) +! IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! ELSE +! cx(mgs,ls) = Max( 0.0, cx(mgs,ls) ) +! ENDIF + end do + end if + + if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then + do mgs = 1,ngscnt + + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) +! IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! ELSE +! cx(mgs,lh) = Max( 0.0, cx(mgs,lh) ) +! ENDIF + + end do + ENDIF + + if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then + do mgs = 1,ngscnt + + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) +! IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN +! cx(mgs,lhl) = 0.0 +! ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN +! qx(mgs,lhl) = 0.0 +! ELSE +! cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) ) +! ENDIF + + end do + end if + + do mgs = 1,ngscnt + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) +! IF ( ls .gt. 1 .and. lvs .eq. 0 ) xdn(mgs,ls) = xdn0(ls) +! IF ( lh .gt. 1 .and. lvh .eq. 0 ) xdn(mgs,lh) = xdn0(lh) + IF ( li .gt. 1 ) xdn(mgs,li) = xdn0(li) + IF ( ls .gt. 1 ) xdn(mgs,ls) = xdn0(ls) + IF ( lh .gt. 1 ) xdn(mgs,lh) = xdn0(lh) + IF ( lhl .gt. 1 ) xdn(mgs,lhl) = xdn0(lhl) + end do + +! +! Set mean particle volume +! + IF ( ldovol .and. (ildo == 0 .or. ildo >= li ) ) THEN + + vx(:,:) = 0.0 + + DO il = l1,l2 + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + IF ( vx(mgs,il) .gt. rho0(mgs)*qxmin(il)*1.e-3 .and. qx(mgs,il) .gt. qxmin(il) ) THEN + xdn(mgs,il) = Min( xdnmx(il), Max( xdnmn(il), rho0(mgs)*qx(mgs,il)/vx(mgs,il) ) ) + ENDIF + ENDDO + + ENDIF + + ENDDO + + ENDIF + + DO il = lg,lhab + DO mgs = 1,ngscnt + alpha(mgs,il) = dnu(il) + ENDDO + ENDDO + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + + + + + + +! +! Set density +! + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' +! + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + +! +! put fall speeds into the x-z arrays +! + DO il = l1,l2 + do mgs = 1,ngscnt + + vtmax = 150.0 + + + IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & + & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN + + + + vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) + + ENDIF + + + IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & + & vtxbar(mgs,il,3) .gt. vtmax ) THEN + + vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) + vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) + +! call commasmpi_abort() + ENDIF + + + xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1) + xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2) + IF ( infdo .ge. 2 ) THEN + xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3) + ELSE + xvt(kgs(mgs),igs(mgs),3,il) = 0.0 + ENDIF + +! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il) + + enddo + ENDDO + + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' + + + + 9998 continue + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: DONE WITH LOOP' + + if ( kz .gt. nz-1 ) then + go to 1200 + else + nzmpb = kz + end if + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB' + + end do !! inumgs + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NXMPB' + + 1200 continue + + +! ENDDO ! ix +! ENDDO ! kz + + + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE" + + + RETURN + END subroutine ziegfall1d + +! ##################################################################### +! ##################################################################### + + +! ##################################################################### +! ##################################################################### + +! ############################################################################## + subroutine radardd02(nx,ny,nz,nor,na,an,temk, & + & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit) +! +! 11.13.2005: Changed values of indices for reordering of lip +! +! 07.13.2005: Fixed an error where cnoh was being used for graupel and frozen drops +! +! 01.24.2005: add ice crystal reflectivity using parameterization of +! Heymsfield (JAS, 1977). Could also try Ferrier for this, too. +! +! 09.28.2002 Test alterations for dry ice following Ferrier (1994) +! for equivalent melted diameter reflectivity. +! Converted to Fortran by ERM. +! +!Date: Tue, 21 Nov 2000 10:13:36 -0600 (CST) +!From: Matthew Gilmore +! +!PRO RF_SPEC ; Computes Radar Reflectivity +!COMMON MAINB, data, x1d, y1d, z1d, iconst, rconst, labels, nx, ny, nz, dshft +! +!;MODIFICATION HISTORY +!; 5/99 -Svelta Veleva introduces variable dielf (const_ki_x) as a (weak) +!; function of density. This leads to slight modification of dielf such +!; that the snow reflectivity is slightly increased - not a big effect. +!; This is believed to be more accurate than assuming the dielectric +!; constant for snow is the same as for hail in previous versions. +! +!;On 6/13/99 I added the VIL computation (k=0 in vil array) +!;On 6/15/99 I removed the number concentration dependencies as a function +!; of temperature (only use for ferrier!) +!;On 6/15/99 I added the Composite reflectivity (k=1 in VIL array) +!;On 6/15/99 I added the Severe Hail Index computation (k=2 in vil array) +!; +!; 6/99 - Veleva and Seo argue that since graupel is more similar to +!; snow (in number conc and size density) than it is to hail, we +!; should not weight wetted graupel with the .95 exponent correction +!; factor as in the case of hail. An if-statement checks the size +!; density for wet hail/graupel and treats them appropriately. +!; +!; 6/22/99 - Added function to compute height of max rf and 40 dbz echo top +!; Also added vilqr which is the model vertical integrated liquid only +!; using qr. Will need to check...does not seem consistent with vilZ +!; + + + implicit none + + character(LEN=15), parameter :: microp = 'ZVD' + integer nx,ny,nz,nor,na,ngt + integer nzdbz ! how many levels actually to process + + integer ng1,n10 + integer iunit + integer, parameter :: printyn = 0 + + parameter( ng1 = 1 ) + + real cnoh0t,hwdn1t + integer ke_diag + integer ipconc + real vr + + + integer imapz,mzdist + + integer vzflag + integer, parameter :: norz = 3 + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air density +! real gt(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,ngt) + real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air temperature (kelvin) + real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! reflectivity + real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4) + +! real g,rgas,eta,inveta + real cr1, cr2 , hwdnsq,swdnsq + real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc + real reflectmin, kw_sq + real const_ki_sn, const_ki_h, ki_sq_sn + real ki_sq_h, dielf_sn, dielf_h + real pi + logical ltest + +! Other data arrays + real gtmp (nx,nz) + real dtmp (nx,nz) + real tmp + + real*8 dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x + + integer i,j,k,ix,jy,kz,ihcnt + + real*8 xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc + real*8 dadr + real dbzmax,dbzmin + parameter ( dbzmin = 0 ) + + real cnow,cnoi,cnoip,cnoir,cnor,cnos + real cnogl,cnogm,cnogh,cnof,cnoh,cnohl + + real swdn, rwdn ,hwdn,gldn,gmdn,ghdn,fwdn,hldn + real swdn0 + + real rwdnmx,cwdnmx,cidnmx,xidnmx,swdnmx,gldnmx,gmdnmx + real ghdnmx,fwdnmx,hwdnmx,hldnmx + real rwdnmn,cwdnmn,cidnmn,xidnmn,swdnmn,gldnmn,gmdnmn + real ghdnmn,fwdnmn,hwdnmn,hldnmn + + real gldnsq,gmdnsq,ghdnsq,fwdnsq,hldnsq + + real dadgl,dadgm,dadgh,dadhl,dadf + real zgldryc,zglwetc,zgmdryc, zgmwetc,zghdryc,zghwetc + real zhldryc,zhlwetc,zfdryc,zfwetc + + real dielf_gl,dielf_gm,dielf_gh,dielf_hl,dielf_fw + + integer imx,jmx,kmx + + real swdia,gldia,gmdia,ghdia,fwdia,hwdia,hldia + + real csw,cgl,cgm,cgh,cfw,chw,chl + real xvs,xvgl,xvgm,xvgh,xvf,xvh,xvhl + + real cwc0 + integer izieg + integer ice10 + real rhos + parameter ( rhos = 0.1 ) + + real qxw,qxw1 ! temp value for liquid water on ice mixing ratio + real :: dnsnow + real qh + + real, parameter :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwradn = 5.0e-6 ! minimum radius + + real cwnccn(nz) + + real :: vzsnow, vzrain, vzgraupel, vzhail + real :: ksq + real :: dtp + + +! ######################################################################### + + vzflag = 0 + + izieg = 0 + ice10 = 0 +! g=9.806 ! g: gravity constant +! rgas=287.04 ! rgas: gas constant for dry air +! rcp=rgas/cp ! rcp: gamma constant +! eta=0.622 +! inveta = 1./eta +! rcpinv = 1./rcp +! cpr=cp/rgas +! cvr=cv/rgas + pi = 4.0*ATan(1.) + cwc0 = piinv ! 1./pi ! 6.0/pi + + cnoh = cnoh0t + hwdn = hwdn1t + + rwdn = 1000.0 + swdn = 100.0 + + qrmin = 1.0e-05 + qsmin = 1.0e-06 + qhmin = 1.0e-05 + +! +! default slope intercepts +! + cnow = 1.0e+08 + cnoi = 1.0e+08 + cnoip = 1.0e+08 + cnoir = 1.0e+08 + cnor = 8.0e+06 + cnos = 8.0e+06 + cnogl = 4.0e+05 + cnogm = 4.0e+05 + cnogh = 4.0e+05 + cnof = 4.0e+05 + cnohl = 1.0e+03 + + + imx = 1 + jmx = 1 + kmx = 1 + i = 1 + + + IF ( microp(1:4) .eq. 'ZIEG' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + +! write(0,*) 'Set reflectivity for ZIEG' + izieg = 1 + + hwdn = hwdn1t ! 500. + + + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF + + ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + + izieg = 1 + + swdn0 = swdn + + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF +! write(*,*) 'radardbz: ',db(1,1,1),temk(1,1,1),an(1,1,1,lr),an(1,1,1,ls),an(1,1,1,lh) + + + ENDIF + + +! cdx(lr) = 0.60 +! +! IF ( lh > 1 ) THEN +! cdx(lh) = 0.8 ! 1.0 ! 0.45 +! cdx(ls) = 2.00 +! ENDIF +! +! IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 +! +! xvmn(lc) = xvcmn +! xvmn(lr) = xvrmn +! +! xvmx(lc) = xvcmx +! xvmx(lr) = xvrmx +! +! IF ( lh > 1 ) THEN +! xvmn(ls) = xvsmn +! xvmn(lh) = xvhmn +! xvmx(ls) = xvsmx +! xvmx(lh) = xvhmx +! ENDIF +! +! IF ( lhl .gt. 1 ) THEN +! xvmn(lhl) = xvhlmn +! xvmx(lhl) = xvhlmx +! ENDIF +! +! xdnmx(lr) = 1000.0 +! xdnmx(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmx(li) = 917.0 +! xdnmx(ls) = 300.0 +! xdnmx(lh) = 900.0 +! ENDIF +! IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 +!! +! xdnmn(:) = 900.0 +! +! xdnmn(lr) = 1000.0 +! xdnmn(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmn(li) = 100.0 +! xdnmn(ls) = 100.0 +! xdnmn(lh) = hdnmn +! ENDIF +! IF ( lhl .gt. 1 ) xdnmn(lhl) = 500.0 +! +! xdn0(:) = 900.0 +! +! xdn0(lc) = 1000.0 +! xdn0(lr) = 1000.0 +! IF ( lh > 1 ) THEN +! xdn0(li) = 900.0 +! xdn0(ls) = 100.0 ! 100.0 +! xdn0(lh) = hwdn1t ! (0.5)*(xdnmn(lh)+xdnmx(lh)) +! ENDIF +! IF ( lhl .gt. 1 ) xdn0(lhl) = 800.0 + +! +! slope intercepts +! +! cnow = 1.0e+08 +! cnoi = 1.0e+08 +! cnoip = 1.0e+08 +! cnoir = 1.0e+08 +! cnor = 8.0e+06 +! cnos = 8.0e+06 +! cnogl = 4.0e+05 +! cnogm = 4.0e+05 +! cnogh = 4.0e+05 +! cnof = 4.0e+05 +!c cnoh = 4.0e+04 +! cnohl = 1.0e+03 +! +! +! density maximums and minimums +! + rwdnmx = 1000.0 + cwdnmx = 1000.0 + cidnmx = 917.0 + xidnmx = 917.0 + swdnmx = 200.0 + gldnmx = 400.0 + gmdnmx = 600.0 + ghdnmx = 800.0 + fwdnmx = 900.0 + hwdnmx = 900.0 + hldnmx = 900.0 +! + rwdnmn = 1000.0 + cwdnmn = 1000.0 + xidnmn = 001.0 + cidnmn = 001.0 + swdnmn = 001.0 + gldnmn = 200.0 + gmdnmn = 400.0 + ghdnmn = 600.0 + fwdnmn = 700.0 + hwdnmn = 700.0 + hldnmn = 900.0 + + + gldn = (0.5)*(gldnmn+gldnmx) ! 300. + gmdn = (0.5)*(gmdnmn+gmdnmx) ! 500. + ghdn = (0.5)*(ghdnmn+ghdnmx) ! 700. + fwdn = (0.5)*(fwdnmn+fwdnmx) ! 800. + hldn = (0.5)*(hldnmn+hldnmx) ! 900. + + + cr1 = 7.2e+20 + cr2 = 7.295e+19 + hwdnsq = hwdn**2 + swdnsq = swdn**2 + rwdnsq = rwdn**2 + + gldnsq = gldn**2 + gmdnsq = gmdn**2 + ghdnsq = ghdn**2 + fwdnsq = fwdn**2 + hldnsq = hldn**2 + + dhmin = 0.005 + tfr = 273.16 + tfrh = tfr - 8.0 + zrc = cr1*cnor + reflectmin = 0.0 + kw_sq = 0.93 + dbzmax = dbzmin + + ihcnt=0 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Dielectric Factor - Formulas implemented by Svetla Veleva +! following Battan, "Radar Meteorology" - p. 40 +! The result of these calculations is that the dielf numerator (ki_sq) without +! the density ratio is .2116 for hail if using 917 density and .25 for +! snow if using 220 density. +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + const_ki_sn = 0.5 - (0.5-0.46)/(917.-220.)*(swdn-220.) + const_ki_h = 0.5 - (0.5-0.46)/(917.-220.)*(hwdn-220.) + ki_sq_sn = (swdnsq/rwdnsq) * const_ki_sn**2 + ki_sq_h = (hwdnsq/rwdnsq) * const_ki_h**2 + dielf_sn = ki_sq_sn / kw_sq + dielf_h = ki_sq_h / kw_sq + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the next line if you want to hardwire dielf for dry hail for both dry +! snow and dry hail. +! This would be equivalent to what Straka had originally. (i.e, .21/.93) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + dielf_sn = (swdnsq/rwdnsq)*.21/ kw_sq + dielf_h = (hwdnsq/rwdnsq)*.21/ kw_sq + + dielf_gl = (gldnsq/rwdnsq)*.21/ kw_sq + dielf_gm = (gmdnsq/rwdnsq)*.21/ kw_sq + dielf_gh = (ghdnsq/rwdnsq)*.21/ kw_sq + dielf_hl = (hldnsq/rwdnsq)*.21/ kw_sq + dielf_fw = (fwdnsq/rwdnsq)*.21/ kw_sq + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Notes on dielectric factors - from Eun-Kyoung Seo +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! constants for both snow and hail would be (x=s,h)..... +! xwdnsq/rwdnsq *0.21/kw_sq ! Straka/Smith - the original +! xwdnsq/rwdnsq *0.224 ! Ferrier - for particle sizes in equiv. drop diam +! xwdnsq/rwdnsq *0.176/kw_sq ! =0.189 in Smith - for particle sizes in equiv +! ice spheres +! xwdnsq/rwdnsq *0.208/kw_sq ! Smith 1984 - for particle sizes in equiv melted drop diameter +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! VIL algorithm constants +! Ztop = 10.**(56./10) !56 dbz is the max rf used by WATADS in cell vil + + +! Hail detection algorithm constants +! ZL = 40. +! ZU = 50. +! Ho = 3400. !WATADS Defaults +! Hm20 = 6200. !WATADS Defaults + +! DO kz = 1,Min(nzdbz,nz-1) + + DO jy=1,1 + + DO kz = 1,ke_diag ! nz + + DO ix=1,nx + dbz(ix,jy,kz) = 0.0 + + vzsnow = 0.0 + vzrain = 0.0 + vzgraupel = 0.0 + vzhail = 0.0 + + dtmph = 0.0 + dtmps = 0.0 + dtmphl = 0.0 + dtmpr = 0.0 + dadr = (db(ix,jy,kz)/(pi*rwdn*cnor))**(0.25) +!----------------------------------------------------------------------- +! Compute Rain Radar Reflectivity +!----------------------------------------------------------------------- + + dtmp(ix,kz) = 0.0 + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,lr) .ge. qrmin ) THEN + IF ( ipconc .le. 2 ) THEN + gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) + dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 + ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN + IF ( imurain == 3 ) THEN + vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) + dtmp(ix,kz) = 3.6e18*(rnu+2.)*an(ix,jy,kz,lnr)*vr**2/(rnu+1.) + ELSE ! imurain == 1 + g1 = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lr))**2/an(ix,jy,kz,lnr) + ze =1.e18*zx*(6./(pi*1000.))**2 ! note: using 1000. here for water density + dtmp(ix,kz) = ze + ENDIF + ENDIF + dtmpr = dtmp(ix,kz) + ENDIF + +!----------------------------------------------------------------------- +! Compute snow and graupel reflectivity +! +! Lou modified to look at parcel temperature rather than base state +!----------------------------------------------------------------------- + + IF( lhab .gt. lr ) THEN + +! qs2d = reform(data[*,*,k,10],[nx*ny]) +! qh2d = reform(data[*,*,k,11],[nx*ny]) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Straka GEMS microphysics +! (Sam 1-d version modified by L Wicker does not use this) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ;xcnoh = cnoh*exp(-0.025*(temp-tfr)) +! ;xcnos = cnos*exp(-0.038*(temp-tfr)) +! ;good = where(temp GT tfr, n_elements) +! ;IF n_elements NE 0 THEN xcnoh(good) = cnoh*exp(-0.075*(temp(good)-tfr)) +! ;IF n_elements NE 0 THEN xcnos(good) = cnos*exp(-0.088*(temp(good)-tfr)) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Ferrier micro with No=No(T) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ; NOSE = -.15 +! ; NOGE = .0 +! ; xcnoh = cnoh*(1.>exp(NOGE*(temp-tfr)) ) +! ; xcnos = cnos*(1.>exp(NOSE*(temp-tfr)) ) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the following lines if Nos and Noh are constant +! (As in Svetla version of Ferrier, GCE Tao, and SAM 1-d) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + xcnoh = cnoh + xcnos = cnos + +! +! Temporary fix for predicted number concentration -- need a +! more appropriate reflectivity equation! +! +! IF ( an(ix,jy,kz,lns) .lt. 0.1 ) THEN +! swdia = (xvrmn*cwc0)**(1./3.) +! xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvrmn*swdn*swdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! swdia = +! > (an(ix,jy,kz,ls)*db(ix,jy,kz) +! > /(pi*swdn*an(ix,jy,kz,lns)))**(1./3.) +! +! xcnos = an(ix,jy,kz,lns)/swdia +! ENDIF + + IF ( ls .gt. 1 ) THEN ! { + + IF ( lvs .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + swdn = db(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + swdn = Min( 300., Max( 100., swdn ) ) + ELSE + swdn = swdn0 + ENDIF + + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { + + xvs = db(ix,jy,kz)*an(ix,jy,kz,ls)/ & + & (swdn*Max(1.0e-3,an(ix,jy,kz,lns))) + IF ( xvs .lt. xvsmn .or. xvs .gt. xvsmx ) THEN + xvs = Min( xvsmx, Max( xvsmn,xvs ) ) + csw = db(ix,jy,kz)*an(ix,jy,kz,ls)/(xvs*swdn) + ENDIF + + swdia = (xvs*cwc0)**(1./3.) + xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvs*swdn*swdia) + + ENDIF ! } + ENDIF ! } + +! IF ( an(ix,jy,kz,lnh) .lt. 0.1 ) THEN +! hwdia = (xvrmn*cwc0)**(1./3.) +! xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvrmn*hwdn*hwdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! hwdia = +! > (an(ix,jy,kz,lh)*db(ix,jy,kz) +! > /(pi*hwdn*an(ix,jy,kz,lnh)))**(1./3.) +! +! xcnoh = an(ix,jy,kz,lnh)/hwdia +! ENDIF + + IF ( lh .gt. 1 ) THEN ! { + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( hdnmn, hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF + ELSE + hwdn = hwdn1t + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { + + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/ & + & (hwdn*Max(1.0e-3,an(ix,jy,kz,lnh))) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF + + hwdia = (xvh*cwc0)**(1./3.) + xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvh*hwdn*hwdia) + + ENDIF ! } ipconc .ge. 5 + + ENDIF ! } + + dadh = 0.0 + dadhl = 0.0 + dads = 0.0 + IF ( xcnoh .gt. 0.0 ) THEN + dadh = ( db(ix,jy,kz) /(pi*hwdn*xcnoh) )**(.25) + zhdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnoh ! dielf_h*cr1*xcnoh ! SV - equiv formula as before but + ! ratio of densities included in + ! dielf_h rather than here following + ! Battan. + ELSE + dadh = 0.0 + zhdryc = 0.0 + ENDIF + + IF ( xcnos .gt. 0.0 ) THEN + dads = ( db(ix,jy,kz) /(pi*swdn*xcnos) )**(.25) + zsdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnos ! dielf_sn*cr1*xcnos ! SV - similar change as above + ELSE + dads = 0.0 + zsdryc = 0.0 + ENDIF + zhwetc = zhdryc ! cr1*xcnoh !Hail/graupel version with .95 power bug removed + zswetc = zsdryc ! cr1*xcnos +! +! snow contribution +! + IF ( ls .gt. 1 ) THEN + + gtmp(ix,kz) = 0.0 + qxw = 0.0 + qxw1 = 0.0 + dtmps = 0.0 + IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN !{ + IF ( ipconc .ge. 4 ) THEN ! (Ferrier 94) !{ + + if (lsw .gt. 1) THEN + qxw = an(ix,jy,kz,lsw) + qxw1 = 0.0 + ELSEIF ( iusewetsnow == 1 .and. temk(ix,jy,kz) .gt. tfr+1. .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) & + & .and. an(ix,jy,kz,lr) > qsmin) THEN + qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr)) + qxw1 = qxw + ENDIF + + vr = xvs ! db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) +! gtmp(ix,kz) = 3.6e18*(0.243*rhos**2/0.93)*(snu+2.)*an(ix,jy,kz,lns)*vr**2/(snu+1.) + + ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere + IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN + IF ( .true. ) THEN +! IF ( qxw > qsmin ) THEN ! old version +! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & +! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + + ENDIF + + ENDIF + +! tmp = Min(1.0,1.e3*(an(ix,jy,kz,ls))*db(ix,jy,kz)) +! gtmp(ix,kz) = Max( 1.0*gtmp(ix,kz), 750.0*(tmp)**1.98) + dtmps = gtmp(ix,kz) + dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz) + ELSE ! }{ single-moment snow: + gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25) + + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN !{ + dtmps = zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ELSE + dtmp(ix,kz) = dtmp(ix,kz) + & + & zswetc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ENDIF + ENDIF !} + ENDIF !} + + ENDIF !} + + ENDIF + + +! +! ice crystal contribution (Heymsfield, 1977, JAS) +! + IF ( li .gt. 1 .and. idbzci .ne. 0 ) THEN + + IF ( idbzci == 1 .and. lni > 0 ) THEN + ! assume spherical ice with density of 900 for dbz calc + IF ( an(ix,jy,kz,li) > qxmin(li) .and. an(ix,jy,kz,lni) > 1.0 ) THEN + vr = db(ix,jy,kz)*an(ix,jy,kz,li)/(900.*an(ix,jy,kz,lni)) + dtmp(ix,kz) = dtmp(ix,kz) + & + & 0.224*3.6e18*(cinu+2.)*an(ix,jy,kz,lni)*vr**2/(cinu+1.)*(900./1000.)**2 + ENDIF + + ELSEIF ( idbzci == 2 ) THEN +! +! ice crystal contribution (Heymsfield, 1977, JAS) +! + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,li) .ge. 0.1e-3 ) THEN + gtmp(ix,kz) = Min(1.0,1.e3*(an(ix,jy,kz,li))*db(ix,jy,kz)) + dtmp(ix,kz) = dtmp(ix,kz) + 750.0*(gtmp(ix,kz))**1.98 + ENDIF + + ENDIF + + ENDIF + +! +! graupel/hail contribution +! + IF ( lh .gt. 1 ) THEN ! { + gtmp(ix,kz) = 0.0 + dtmph = 0.0 + qxw = 0.0 + + IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN + + ltest = .false. + + IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN + + IF ( lvh .gt. 1 ) THEN + + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( 100., hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF + + ENDIF + + chw = an(ix,jy,kz,lnh) + IF ( chw .gt. 0.0 ) THEN ! (Ferrier 94) + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*Max(1.0e-3,chw)) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF + + qh = an(ix,jy,kz,lh) + + IF ( lhw .gt. 1 ) THEN + IF ( iusewetgraupel .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhw) + ELSEIF ( iusewetgraupel .eq. 2 ) THEN + IF ( hwdn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhw) + ENDIF + ENDIF + ELSEIF ( iusewetgraupel .eq. 3 ) THEN + IF ( hwdn .lt. 300. .and. temk(ix,jy,kz) > tfr .and. an(ix,jy,kz,lr) > qhmin ) THEN + qxw = Min( an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw + ENDIF + ELSEIF ( iusewetgraupel == 4 .and. temk(ix,jy,kz) .gt. tfr+0.25 .and. an(ix,jy,kz,lh) > an(ix,jy,kz,lr) & + & .and. an(ix,jy,kz,lr) > qhmin) THEN + qxw = Min(0.5*an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw + + ENDIF + + IF ( lzh .gt. 1 ) THEN + ELSE + g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw +! ze = 0.224*1.e18*zx*(6./(pi*1000.))**2 + zx = g1*db(ix,jy,kz)**2*( 0.224*qh + 0.776*qxw)*qh/chw + ze =1.e18*zx*(6./(pi*1000.))**2 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmph = ze + ENDIF + + ENDIF + + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF + + ELSE + + dtmph = 0.0 + + IF ( an(ix,jy,kz,lh) .ge. qhmin ) THEN + gtmp(ix,kz) = dadh*an(ix,jy,kz,lh)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN + dtmph = zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) +! +! & (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF + ENDIF + + + + ENDIF + + + ENDIF ! } + + ENDIF ! na .gt. 5 + + + IF ( izieg .ge. 1 .and. lhl .gt. 1 ) THEN + + hldn = 900.0 + gtmp(ix,kz) = 0.0 + dtmphl = 0.0 + qxw = 0.0 + + + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hldn = db(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + hldn = Min( 900., Max( 300., hldn ) ) + ELSE + hldn = 900. + ENDIF + ELSE + hldn = rho_qhl + ENDIF + + + IF ( ipconc .ge. 5 ) THEN + + ltest = .false. + + IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ + chl = an(ix,jy,kz,lnhl) + IF ( chl .gt. 0.0 ) THEN !{ + xvhl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/ & + & (hldn*Max(1.0e-9,an(ix,jy,kz,lnhl))) + IF ( xvhl .lt. xvhlmn .or. xvhl .gt. xvhlmx ) THEN ! { + xvhl = Min( xvhlmx, Max( xvhlmn,xvhl ) ) + chl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvhl*hldn) + ! do not update state in dbz calc. ! an(ix,jy,kz,lnhl) = chl + ENDIF ! } + + IF ( lhlw .gt. 1 ) THEN + IF ( iusewethail .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhlw) + ELSEIF ( iusewethail .eq. 2 ) THEN + IF ( hldn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhlw) + ENDIF + ENDIF + ENDIF + + IF ( lzhl .gt. 1 ) THEN !{ + ELSE !} + + g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lhl) + 0.776*qxw)*an(ix,jy,kz,lhl)/chl +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lhl))**2/chl + ze = 1.e18*zx*(6./(pi*1000.))**2 ! 3/28/2016 removed extra factor of 0.224 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmphl = ze + + ENDIF !} + ENDIF!} + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF + + + ELSE + + + IF ( an(ix,jy,kz,lhl) .ge. qhlmin ) THEN ! { + dadhl = ( db(ix,jy,kz) /(pi*hldn*cnohl) )**(.25) + gtmp(ix,kz) = dadhl*an(ix,jy,kz,lhl)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN ! { + + zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl + + dtmphl = zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) + + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) +! +! : (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF ! } + + ENDIF ! } + + ENDIF ! ipconc .ge. 5 + + + ENDIF ! izieg .ge. 1 .and. lhl .gt. 1 + + + + IF ( dtmp(ix,kz) .gt. 0.0 ) THEN + dbz(ix,jy,kz) = Max(dbzmin, 10.0*Log10(dtmp(ix,kz)) ) + + IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN + dbzmax = Max(dbzmax,dbz(ix,jy,kz)) + imx = ix + jmx = jy + kmx = kz + ENDIF + ELSE + dbz(ix,jy,kz) = dbzmin + IF ( lh > 1 .and. lhl > 1) THEN + IF ( an(ix,jy,kz,lh) > 1.0e-3 ) THEN + write(0,*) 'radardbz: qr,qh,qhl = ',an(ix,jy,kz,lr), an(ix,jy,kz,lh),an(ix,jy,kz,lhl) + write(0,*) 'radardbz: dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + + IF ( lzh>1 .and. lzhl>1 ) write(0,*) 'radardbz: zh, zhl = ',an(ix,jy,kz,lzh),an(ix,jy,kz,lzhl) + ENDIF + ENDIF + ENDIF + +! IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and. +! & dbz(ix,jy,kz) .le. 0.0 ) THEN +! write(0,*) 'dbz = ',dbz(ix,jy,kz) +! write(0,*) 'Hail intercept: ',xcnoh,ix,kz +! write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) +! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) +! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph +! ENDIF + IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN +! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN +! write(0,*) 'my_rank = ',my_rank + write(0,*) 'ix,jy,kz = ',ix,jy,kz + write(0,*) 'dbz = ',dbz(ix,jy,kz) + write(0,*) 'db, zhdryc = ',db(ix,jy,kz),zhdryc + write(0,*) 'Hail intercept: ',xcnoh,ix,kz + write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) + write(0,*) 'graupel density hwdn = ',hwdn + write(0,*) 'rain q: ',an(ix,jy,kz,lr) + write(0,*) 'ice q: ',an(ix,jy,kz,li) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lhl): ',an(ix,jy,kz,lhl) + IF (ipconc .ge. 3 ) write(0,*) 'rain c: ',an(ix,jy,kz,lnr) + IF ( lzr > 1 ) write(0,*) 'rain Z: ',an(ix,jy,kz,lzr) + IF ( ipconc .ge. 5 ) THEN + write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lnhl): ',an(ix,jy,kz,lnhl) + IF ( lzhl .gt. 1 ) THEN + write(0,*) 'Hail (lzhl): ',an(ix,jy,kz,lzhl) + write(0,*) 'chl,xvhl,dhl = ',chl,xvhl,(xvhl*6./3.14159)**(1./3.) + write(0,*) 'xvhlmn,xvhlmx = ',xvhlmn,xvhlmx + ENDIF + ENDIF + write(0,*) 'chw,xvh = ', chw,xvh + write(0,*) 'dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + write(0,*) 'dtmpr = ',dtmpr + write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) + IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN + write(0,*) 'dbz out of bounds! STOP!' +! STOP + ENDIF + ENDIF + + + ENDDO ! ix + ENDDO ! kz + ENDDO ! jy + + + + +! write(0,*) 'na,lr = ',na,lr + IF ( printyn .eq. 1 ) THEN +! IF ( dbzmax .gt. dbzmin ) THEN + write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx + write(iunit,*) 'qrw = ',an(imx,jmx,kmx,lr) + + IF ( lh .gt. 1 ) THEN + write(iunit,*) 'qi = ',an(imx,jmx,kmx,li) + write(iunit,*) 'qsw = ',an(imx,jmx,kmx,ls) + write(iunit,*) 'qhw = ',an(imx,jmx,kmx,lh) + IF ( lhl .gt. 1 ) write(iunit,*) 'qhl = ',an(imx,jmx,kmx,lhl) + ENDIF + + + ENDIF + + + RETURN + END subroutine radardd02 + + +! ############################################################################## +! ############################################################################## + + +! ##################################################################### +! ##################################################################### +! +! Subroutine for explicit cloud condensation and droplet nucleation +! + SUBROUTINE NUCOND & + & (nx,ny,nz,na,jyslab & + & ,nor,norz,dtp,nxi & + & ,dz3d & + & ,t0,t9 & + & ,an,dn,p2 & + & ,pn,w & + & ,axtra,io_flag & + & ,ssfilt,t00,t77,flag_qndrop & + & ) + + + implicit none + + integer :: nx,ny,nz,na,nxi + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + logical :: flag_qndrop + + integer, parameter :: ng1 = 1 + + +! +! external temporary arrays +! + real t00(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t8(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t9(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real qv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real ssfilt(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + ! local + + + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + logical :: io_flag + + real :: dv + +! +! declarations microphysics and for gather/scatter +! + real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. + real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. + integer nxmpb,nzmpb,nxz + integer mgs,ngs,numgs,inumgs + parameter (ngs=500) + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs) + integer nsvcnt + + integer ix,kz,i,n, kp1, km1 + integer :: jy, jgs + integer ixb,ixe,jyb,jye,kzb,kze + + integer itile,jtile,ktile + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + +! +! Variables for Ziegler warm rain microphysics +! + + + real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) + real ccncuf(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real :: ssmax(ngs) = 0.0 ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real ventrx(ngs) + real ventrxn(ngs) + real volb, t2s + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler + + real ec0, ex1, ft, rhoinv(ngs) + + real chw, g1, rd1 + + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super + real tmpmx, fw, qctmp + real x,y,del,r,alpr + double precision :: vent1,vent2 + real g1palp + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation + + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real dcrit + real cn(ngs), cnuf(ngs) + real :: ccwmax + + integer ltemq + + integer il + + real es(ngs) ! ss(ngs), +! real eis(ngs) + real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs) + real, parameter :: ssfcut = 4.0 + real ssfjp1(ngs),ssfjm1(ngs) + real ssfip1(ngs),ssfim1(ngs) + + real supcb, supmx + parameter (supcb=0.5,supmx=238.0) + real r2dxm, r2dym, r2dzm + real dssdz, dssdy, dssdx +! real tqvcon + real epsi,d + parameter (epsi = 0.622, d = 0.266) + real r1,qevap ! ,slv + + real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc + real ctmp, ccwtmp + real f5, qvs0 ! Kessler condensation factor + real :: t0p1, t0p3 + real qvex + +! real, dimension(ngs) :: temp, tempc, elv, elf, els, pqs, theta, temg, temcg + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs) + real temp(ngs),tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) ! ,tembzg(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real felv(ngs),felf(ngs),fels(ngs) + real felvcp(ngs),felvpi(ngs) + real gamw(ngs),gams(ngs) ! qciavl(ngs), + real tsqr(ngs),ssi(ngs),ssw(ngs) + real cc3(ngs),cqv1(ngs),cqv2(ngs) + real qcwtmp(ngs),qtmp + + real fvent(ngs) !,fraci(ngs),fracl(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) + real fschm(ngs),fpndl(ngs) + + real pres(ngs),pipert(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs) + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real qss0(ngs) + real fcqv1(ngs) + real wvel(ngs),wvelkm1(ngs) + + real wvdf(ngs),tka(ngs) + real advisc(ngs) + + real rwvent(ngs) + + + real :: qx(ngs,lv:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + + + logical zerocx(lc:lqmx) + + logical :: lprint + + integer, parameter :: iunit = 0 + + real :: frac, hwdn, tmpg + + real :: cvm,cpm,rmm + + real, parameter :: rovcp = rd/cp + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure + + integer :: kstag + + integer :: count + + +! ------------------------------------------------------------------------------- + itile = nxi + jtile = ny + ktile = nz + ixend = nxi + jyend = ny + kzend = nz + nxend = nxi + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73) + + jy = 1 + kstag = 0 + pb(:) = 0.0 + pinit(:) = 0.0 + + IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200 + +! +! Ziegler nucleation +! + +! ssfilt(:,:,:) = 0.0 + ssmx = 0 + count = 0 + + do kz = 1,nz-kstag + do ix = 1,nxi + + temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz) + t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1 = t00(ix,jy,kz)*tabqvs(ltemq) + + IF ( c1 > 0. ) THEN + ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values + ENDIF + + ENDDO + ENDDO + + +! +! jy = 1 ! working on a 2d slab +!! VERY IMPORTANT: SET jgs = jy + + jgs = jy + +! +!..Gather microphysics +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Gather stage' + + nxmpb = 1 + nzmpb = 1 + nxz = nxi*nz + numgs = nxz/ngs + 1 + + + do 2000 inumgs = 1,numgs + + ngscnt = 0 + + + kzb = nzmpb + kze = nz-kstag + ! if (kzbeg .le. nzmpb .and. kzend .gt. nzmpb) kzb = nzmpb + + ixb = nxmpb + ixe = itile + + do kz = kzb,kze + do ix = nxmpb,nxi + + pqs(1) = 380.0/(pn(ix,jy,kz) + pb(kz)) + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) + + temcg(1) = temg(1) - tfr + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) + + qss(1) = qvs(1) + + + if ( temg(1) .lt. tfr ) then + end if +! + if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxsupersat ) .and. & + & ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) & + & )) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 2100 + end if + + end do !ix + + nxmpb = 1 + end do !kz +! if ( jy .eq. (ny-jstag) ) iend = 1 + 2100 continue + + if ( ngscnt .eq. 0 ) go to 29998 + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8' + +! write(0,*) 'NUCOND: dbg = 8, ngscnt,ssmx = ',ngscnt,ssmx + + + qx(:,:) = 0.0 + cx(:,:) = 0.0 + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + +! +! define temporaries for state variables to be used in calculations +! + DO mgs = 1,ngscnt + qx(mgs,lv) = an(igs(mgs),jy,kgs(mgs),lv) + DO il = lc,lhab + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + + qcwtmp(mgs) = qx(mgs,lc) + + + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) ! + thetap(mgs) = 0.0 + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = qx(mgs,lv) + qwvp(mgs) = qx(mgs,lv) - qv0(mgs) + + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/rho0(mgs)) + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) +! pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) +! + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + es(mgs) = 6.1078e2*tabqvs(ltemq) + qss(mgs) = qvs(mgs) + + + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) +! + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + ELSE ! equation set 2 in cm1 + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + IF ( eqtset == 2 ) THEN + + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + + ELSE + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + ENDIF + + ENDIF + + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 +! + fels(mgs) = felv(mgs) + felf(mgs) + fcqv1(mgs) = 4098.0258*felv(mgs)*cpi + + wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pb(kgs(mgs)) + pn(igs(mgs),jgs,kgs(mgs)))) ! diffusivity of water vapor, Hall and Pruppacher (76) + advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) ! dynamic viscosity (SMT; see Beard & Pruppacher 71) + tka(mgs) = tka0*advisc(mgs)/advisc1 ! thermal conductivity + + + ENDDO + + + +! +! load concentrations +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) + cwnccn(mgs) = cwccn*rho0(mgs)/rho00 ! background ccn count + cn(mgs) = 0.0 + IF ( lss > 1 ) THEN + ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) + ELSE + ssmax(mgs) = 0.0 + ENDIF + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = cwnccn(mgs) + ENDIF + IF ( lccnuf .gt. 1 ) THEN + ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf) + ELSE + ccncuf(mgs) = 0.0 + ENDIF + cnuf(mgs) = 0.0 + IF ( lccna > 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ! predicted count of activated ccn + ELSE + IF ( lccn > 1 ) THEN + ccna(mgs) = cwnccn(mgs) - ccnc(mgs) ! diagnose activated ccn as background value - remaining unactivated ccn + ELSE + ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + end do + end if + +! cnuc(1:ngscnt) = cwccn*rho0(mgs)/rho00*(1. - renucfrac) + ccnc(1:ngscnt)*renucfrac + DO mgs = 1,ngscnt + ! default value of renucfrac is 0.0 + IF ( irenuc /= 6 ) THEN + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + ELSE + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac + ENDIF + IF ( renucfrac >= 0.999 ) THEN + IF ( temg(mgs) < 265. ) THEN + IF ( qx(mgs,lc) > 10.*qxmin(lc) .and. w(igs(mgs),jgs,kgs(mgs)) > 2.0 ) THEN + cnuc(mgs) = 0.0 ! Min(cnuc(mgs), 0.5*cx(mgs,lc) ) ! Hack to reduce nucleation at low temp in updraft when ccn are not predicted + ELSE + cnuc(mgs) = 0.1*cnuc(mgs) + ENDIF + ENDIF + ENDIF + ENDDO + +! Set density +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set density' + + do mgs = 1,ngscnt + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + end do + + ventrx(:) = ventr + ventrxn(:) = ventrn + + + +! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit + ssmx = 0.0 + DO mgs = 1,ngscnt + + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,Max(1,kgs(mgs)-1))) + + ssat0(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) + ssf(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) +! ssmx = Max( ssmx, ssf(mgs) ) + + + ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) + ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) + + + ENDDO + + + +! +! cloud water variables +! + + if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables' + + do mgs = 1,ngscnt + xv(mgs,lc) = 0.0 + IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & + & xdn(mgs,lc)*xvmx(lc) ) + + cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. cxmin ) THEN +! xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 +! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSE + xmas(mgs,lc) = cwmasn + ENDIF + ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + + + end do +! +! rain +! + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-9,cx(mgs,lr))) +! parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 ) ! mks + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN + xv(mgs,lr) = xvmx(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) + IF ( imurain == 3 ) THEN +! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) + xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) + ELSE ! imurain == 1, Characteristic diameter (1/lambda) + xdia(mgs,lr,1) = (6.*piinv*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + ENDIF +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + +! Inverse exponential version: +! xdia(mgs,lr,1) = +! > (qx(mgs,lr)*rho0(mgs) +! > /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) + ELSE + xdia(mgs,lr,1) = & + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + end if + else + xdia(mgs,lr,1) = 1.e-9 +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + end if + + end do + + +! +! Ventilation coefficients + + do mgs = 1,ngscnt + + + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) + + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) + + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pres(mgs))) + + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) + + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + + end do +! +! +! Ziegler nucleation +! +! +! cloud evaporation, condensation, and nucleation +! sqsat -> qss(mgs) + + DO mgs=1,ngscnt + dcloud = 0.0 + IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxsupersat ) THEN + CYCLE + ENDIF + + IF( ssat0(mgs) .GT. 0. .OR. ssf(mgs) .GT. 0. ) GO TO 620 +!6/4 IF( qvap(mgs) .EQ. qss(mgs) ) GO TO 631 +! +!.... EVAPORATION. QV IS LESS THAN qss(mgs). +!.... EVAPORATE CLOUD FIRST +! + IF ( qx(mgs,lc) .LE. 0. ) GO TO 631 +!.... CLOUD EVAPORATION. +! convert input 'cp' to cgs + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ & + & (cp*(temg(mgs) - cbw)**2)) + QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) + + + IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 + qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) + thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp + ENDIF + qx(mgs,lc) = 0. + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ENDIF + ENDIF + cx(mgs,lc) = 0. + ELSE + qctmp = qx(mgs,lc) + qwvp(mgs) = qwvp(mgs) + QEVAP + qx(mgs,lc) = qx(mgs,lc) - QEVAP + IF ( qx(mgs,lc) .le. 0. ) THEN + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ENDIF + ENDIF + cx(mgs,lc) = 0. + ELSE + tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ENDIF + cx(mgs,lc) = cx(mgs,lc) - tmp + ENDIF + thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp + ENDIF + + ENDIF + + GO TO 631 + + + 620 CONTINUE + +!.... CLOUD CONDENSATION + + IF ( qx(mgs,lc) .GT. qxmin(lc) .and. cx(mgs,lc) .ge. 1. ) THEN + + + +! ac1 = xdn(mgs,lc)*elv(kgs(mgs))**2*epsi/ +! : (tka(kgs(mgs))*rw*temg(mgs)**2) +! took out xdn factor because it cancels later... + ac1 = felv(mgs)**2/(tka(mgs)*rw*temg(mgs)**2) + + +! bc = xdn(mgs,lc)*rw*temg(mgs)/ +! : (epsi*wvdf(kgs(mgs))*es(mgs)) +! took out xdn factor because it cancels later... + bc = rw*temg(mgs)/(wvdf(mgs)*es(mgs)) + +! bs = rho0(mgs)*((rd*temg(mgs)/(epsi*es(mgs)))+ +! : (epsi*elv(kgs(mgs))**2/(pres(mgs)*temg(mgs)*cp))) + +! taus = Min(dtp, xdn(mgs,lc)*rho0(mgs)*(ac1+bc)/ +! : (4*pi*0.89298*BS*0.5*xdia(mgs,lc,1)*cx(mgs,lc)*xdn(mgs,lc))) + +! + IF ( ssf(mgs) .gt. 0.0 .or. ssat0(mgs) .gt. 0.0 ) THEN + IF ( ny .le. 2 ) THEN +! write(0,*) 'undershoot: ',ssf(mgs), +! : ( (qx(mgs,lv) - dcloud)/c1 - 1.0)*100. + ENDIF + + + + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + + IF ( xdia(mgs,lc,1) .le. 0.0 ) THEN + xmas(mgs,lc) = cwmasn + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + ENDIF + d1 = (1./(ac1 + bc))*4.0*pi*ventc & + & *0.5*xdia(mgs,lc,1)*cx(mgs,lc)*rhoinv(mgs) + + ELSE + d1 = 0.0 + ENDIF + + IF ( rcond .eq. 2 .and. qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > 1.e-9 ) THEN + IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + + ELSE ! imurain == 1 + + IF ( iferwisventr == 1 ) THEN + alpr = Min(alpharmax,alpha(mgs,lr) ) +! alpr = alpha(mgs,lr) + x = 1. + alpr + + tmp = 1 + alpr + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpr + 0.5*bx(lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + +! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK +! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK + vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula) + vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) + + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + + ENDIF ! iferwisventr + + ENDIF ! imurain + + d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & + & *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs) + ELSE + d1r = 0.0 + ENDIF + + + e1 = felvcp(mgs)/(pi0(mgs)) + f1 = pk(mgs) ! (pres(mgs)/poo)**cap + +! +! fifth trial to see what happens: +! + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + ltemq1 = ltemq + temp1 = temg(mgs) + p380 = 380.0/pres(mgs) + +! taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) ) +! nc = NInt(dtp/Min(1.0,0.5*taus)) +! dtcon = dtp/float(nc) + ss1 = qx(mgs,lv)/qvs(mgs) + ss2 = ss1 + temp2 = temp1 + qv1 = qx(mgs,lv) + qvs1 = qvs(mgs) + qis1 = qis(mgs) + dt1 = 0.0 + + +! dtcon = Max(dtcon,0.2) +! nc = Nint(dtp/dtcon) + + ltemq1 = ltemq +! want to start out with a small time step to handle the steep slope +! and fast changes, then can switch to a larger step (dtcon2) for the +! rest of the big time step. +! base the initial time step (dtcon1) on the slope (delta) + IF ( Abs(ss1 - 1.0) .gt. 1.e-5 ) THEN + delta = 0.5*(qv1-qvs1)/(d1*(ss1 - 1.0)) + ELSE + delta = 0.1*dtp + ENDIF +! delta is the extrapolated time to get halfway from qv1 to qvs1 +! want at least 5 time steps to the halfway point, so multiply by 0.2 +! for the initial time step + dtcon1 = Min(0.05,0.2*delta) + nc = Max(5,2*NInt( (dtp-4.0*dtcon1)/delta)) + dtcon2 = (dtp-4.0*dtcon1)/nc + + n = 1 + dt1 = 0.0 + nc = 0 + dqc = 0.0 + dqr = 0.0 + dqi = 0.0 + dqs = 0.0 + dqvii = 0.0 + dqvis = 0.0 + + RK2c: DO WHILE ( dt1 .lt. dtp ) + nc = 0 + IF ( n .le. 4 ) THEN + dtcon = dtcon1 + ELSE + dtcon = dtcon2 + ENDIF + 609 dqv = -(ss1 - 1.)*d1*dtcon + dqvr = -(ss1 - 1.)*d1r*dtcon + dtemp = -0.5*e1*f1*(dqv + dqvr) +! write(0,*) 'RK2c dqv1 = ',dqv +! calculate midpoint values: + ! ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5) + + ! 7.6.2016: Test full calc of ltemq + ltemq1m = (temp1+dtemp-163.15)*fqsati+1.5 + ltemq1m = Min( nqsat, Max(1,ltemq1m) ) + + IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN + write(0,*) 'STOP in nucond line 1192 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,f1,dqv,dqvr = ', dtemp,e1,f1,dqv,dqvr + write(0,*) ' d1,d1r,dtcon,ss1 = ',d1,d1r,dtcon,ss1 + write(0,*) ' dqc, dqr = ',dqc,dqr + write(0,*) ' qv,qc,qr = ',qx(mgs,lv)*1000.,qx(mgs,lc)*1000.,qx(mgs,lr)*1000. + write(0,*) ' i, j, k = ',igs(mgs),jy,kgs(mgs) + write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta + write(0,*) ' nc,dtp = ',nc,dtp + write(0,*) ' rwvent,xdia,crw,ccw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr),cx(mgs,lc) + write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr) + write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1 + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1m) + qv1m = qv1 + dqv + dqvr +! qv1mr = qv1r + dqvr + + qvs1m = qvs1 + dqvs + ss1m = qv1m/qvs1m + + ! check for undersaturation when no ice is present, if so, then reduce time step + IF ( ss1m .lt. 1. .and. (dqvii + dqvis) .eq. 0.0 ) THEN + dtcon = (0.5*dtcon) + IF ( dtcon .ge. dtcon1 ) THEN + GOTO 609 + ELSE + EXIT + ENDIF + ENDIF +! calculate full step: + dqv = -(ss1m - 1.)*d1*dtcon + dqvr = -(ss1m - 1.)*d1r*dtcon + + +! write(0,*) 'RK2a dqv1m = ',dqv + dtemp = -e1*f1*(dqv + dqvr) + + ! ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5) + + ! 7.6.2016: Test full calc of ltemq + ltemq1 = (temp1+dtemp-163.15)*fqsati+1.5 + ltemq1 = Min( nqsat, Max(1,ltemq1) ) + + IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN + write(0,*) 'STOP in nucond line 1230 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,dqv,dqvr = ', dtemp,e1,dqv,dqvr + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1) + + qv1 = qv1 + dqv + dqvr + + dqc = dqc - dqv + dqr = dqr - dqvr + + qvs1 = qvs1 + dqvs + ss1 = qv1/qvs1 + temp1 = temp1 + dtemp + IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or. & + & ss1 .eq. 1.00 .or. & + & ( n .gt. 10 .and. ss1 .lt. 1.0005 ) ) THEN +! write(0,*) 'RK2c break' + EXIT + ELSE + ss2 = ss1 + temp2 = temp1 + dt1 = dt1 + dtcon + n = n + 1 + ENDIF + ENDDO RK2c + + + dcloud = dqc ! qx(mgs,lv) - qv1 + thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr) + + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) + ENDIF + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp + ENDIF + qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + qx(mgs,lr) = qx(mgs,lr) + dqr +! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD + dqr)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & +!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*f1 + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) + +! + + ENDIF ! dcloud .gt. 0. + + + ELSE ! qc .le. qxmin(lc) + +! IF ( ssf(mgs) .gt. 0.0 .and. .not. flag_qndrop ) THEN ! flag_qndrop turns off primary nucleation when using wrf-chem with progn=1 + IF ( ssf(mgs) .gt. 0.0 ) THEN ! .and. ssmax(mgs) .lt. sscb ) THEN ! except that wrf-chem does not seem to initialize qc for activated aerosols, so keep this, after all + + IF ( iqcinit == 1 ) THEN + + qvs0 = 380.*exp(17.27*(temg(mgs)-273.)/(temg(mgs)- 36.))/pk(mgs) + + dcloud = Max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) ) + + ELSEIF ( iqcinit == 3 ) THEN + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & + & ((temg(mgs) - cbw)**2)) + DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + + ELSEIF ( iqcinit == 2 ) THEN +! R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ +! : (cp*(temg(mgs) - cbw)**2)) +! DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + ssmx = ssmxinit + +! IF ( ssf(mgs) > ssmx .and. ssmax(mgs) < 3.0 ) THEN +! IF ( ssf(mgs) > ssmx .and. ccnc(mgs) > 1.0 ) THEN +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK + IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test +! IF ( ssf(mgs) > ssmx ) THEN ! original condition + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + ELSE + dcloud = 0.0 + ENDIF + ENDIF + ELSE + dcloud = 0.0 + ENDIF + + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + ENDIF + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) + +!.... S. TWOMEY (1959) +! Note: get here if there is no previous cloud water and w > 0. + cn(mgs) = 0.0 + + IF ( ncdebug .ge. 1 ) THEN + write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs) + ENDIF + + IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem + + +! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN +! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & + & .and. ncdebug .ge. 1 ) THEN + write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & + & wvel(mgs), dcloud*1.e3 + IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ', & + & 1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3, & + & igs(mgs),kgs(mgs),temcg(mgs), & + & 1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc) + ENDIF + IF ( iccwflg .eq. 1 ) THEN + cn(mgs) = Min(cwccn*rho0(mgs)/rho00, Max(cn(mgs), & + & rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3))) + ENDIF + ELSE + cn(mgs) = 0.0 + dcloud = 0.0 +! cn(mgs) = Min(cwccn, & +! & rho0(mgs)*dcloud/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3) ) + ENDIF + + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) +! ccnc(mgs) = 0.0 + ENDIF +! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccna(mgs) = ccna(mgs) + cn(mgs) + ENDIF + +! write(91,*) 'nuc1: cn, ix, kz = ',cn(mgs),igs(mgs),kgs(mgs),wvel(mgs),cnexp,ccnc(mgs) + + IF( CN(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = CN(mgs) + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN + cx(mgs,lc) = 0. + ELSE + cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn) + ENDIF + + ENDIF ! }.not. flag_qndrop + + GOTO 613 + + END IF ! qc .gt. 0. + +! ES=EES(PIB(K)*PT) +! SQSAT=EPSI*ES/(PB(K)*1000.-ES) + +!.... CLOUD NUCLEATION +! T=PIB(K)*PT +! ES=1.E3*PB(K)*QV/EPSI + + IF ( wvel(mgs) .le. 0. ) GO TO 616 + IF ( cx(mgs,lc) .le. 0. ) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .GT. 1 .and. qx(mgs,lc) .le. qxmin(lc)) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .eq. 1 .and. wvel(mgs) .gt. 0. ) GO TO 613 !TWOMEY (1959) Nucleation +!.... ATTEMPT ZIEGLER CLOUD NUCLEATION IN CLOUD INTERIOR UNLESS... + 616 IF ( ssf(mgs) .LE. SUPCB .AND. wvel(mgs) .GT. 0. ) GO TO 631 !... weakly saturated updraft + IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND. & + & (ssfkp1(mgs) .GE. SUPMX .OR. & + & ssf(mgs) .GE. SUPMX .OR. & + & ssfkm1(mgs) .GE. SUPMX)) GO TO 631 !... too much vapour + IF (ssf(mgs) .LT. 1.E-10 .OR. ssf(mgs) .GE. SUPMX) GO TO 631 !... at the extremes for ss + +! +! get here if ( qc > 0 and ss > supcb) or (w < 0) +! + + if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" !mpidebug + + DSSDZ=0. + r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) + IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) + + IF ( irenuc < 2 ) THEN !{ + + IF ( kzend == nzend ) THEN + t0p3 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+3)) + t0p1 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+1)) + ELSE + t0p3 = t0(igs(mgs),jgs,kgs(mgs)+3) + t0p1 = t0(igs(mgs),jgs,kgs(mgs)+1) + ENDIF + + IF ( ( ssf(mgs) .gt. ssmax(mgs) .or. irenuc .eq. 1 ) & + & .and. ( ( lccn .lt. 1 .and. & + & cx(mgs,lc) .lt. cwccn*(Min(1.0,rho0(mgs)))) .or. & + & ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. ) ) & + & ) THEN + IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & + & .and. ssf(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .LT. SUPMX .and. ssfkp1(mgs) .ge. 0.0 & + & .AND. ssfkm1(mgs) .LT. SUPMX .AND. ssfkm1(mgs) .ge. 0.0 & + & .AND. ssfkp1(mgs) .gt. ssfkm1(mgs) & + & .and. t0p3 .gt. 233.2) THEN + DSSDZ = (ssfkp1(mgs) - ssfkm1(mgs))*R2DZM +! +! otherwise check for cloud base condition with updraft: +! + ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & +! IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 & !) + & .and. ssf(mgs) .gt. 0.0 .and. wvel(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .gt. 0.0 & + & .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 & + & .AND. ssf(mgs) .gt. ssfkm1(mgs) & + & .and. t0p1 .gt. 233.2) THEN + DSSDZ = 2.*(ssf(mgs) - ssfkm1(mgs))*R2DZM ! 1-sided difference + ENDIF + + ENDIF +! +!CLZ IF(wijk.LE.0.) CN=CCN*ssfilt(ix,jy,kz)**CCK +! note: CCN -> cwccn, DELT -> dtp + c1 = Max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ & + & (xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)) + IF ( lccn .lt. 1 ) THEN + CN(mgs) = cwccn*rho0(mgs)/rho00*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & (wvel(mgs)*DSSDZ) ) ! probably the vertical gradient dominates + ELSE + CN(mgs) = & + & Min(ccnc(mgs), cnuc(mgs)*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & ( wvel(mgs)*DSSDZ) ) ) +! IF ( cn(mgs) .gt. 0 ) ccnc(mgs) = ccnc(mgs) - cn(mgs) + ENDIF + + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( ccnc(mgs) .lt. 5.e7 .and. cn(mgs) .ge. 5.e7 ) THEN + cn(mgs) = 5.e7 + ccnc(mgs) = 0.0 + ELSEIF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) + ccnc(mgs) = 0.0 + ENDIF + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF + + ELSEIF ( irenuc == 2 ) THEN !} { + ! simple Twomey scheme +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( .false. .and. ny <= 2 ) THEN + write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn + write(0,*) 'wvel, cnuc, cn = ',wvel(mgs),cnuc(mgs),cn(mgs) + write(0,*) 'ccne0,cnexp,cck = ',ccne0,cnexp,cck + write(0,*) 'part1, part2 = ',CCNE0*cnuc(mgs)**(2./(2.+cck)), Max(0.0,wvel(mgs))**cnexp + write(0,*) 'ccnc, dqc, dqc/cwmasn = ',ccnc(mgs), dqc, 0.5*dqc/cwmasn + ENDIF + + IF ( icnuclimit > 0 ) THEN + tmp = ccnc(mgs) + cx(mgs,lc) + IF ( tmp < 330.34e6 ) THEN + ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 + ELSE + ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 + ENDIF + +! IF ( cn(mgs) > 0. ) THEN +! write(0,*) 'cn,tmp,ccwmax,cx,c-cx = ',cn(mgs),tmp,ccwmax,cx(mgs,lc),ccwmax - cx(mgs,lc) +! ENDIF + + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) + + ENDIF + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 5 ) THEN !} { + + ! modification of Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = Min( cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) + + + IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + + + CN(mgs) = Max( cn(mgs), cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ) ! this allows cn(mgs) > cnuc(mgs) + + ! cn(mgs) = Min( cn(mgs), cnuc(mgs) ) + +! IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + + ELSE + CN(mgs) = Min( cn(mgs), cnuc(mgs) - ccna(mgs) ) ! no more than remaining "base" CCN + ENDIF + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + dcrit = 2.0*2.0e-6 + dcloud = 1000.*dcrit**3*Pi/6. + ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass + ! check new droplet size: + ! tmp is number of droplets at diameter dcrit + tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) + cn(mgs) = Min(tmp, cn(mgs) ) + + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + dcrit = 2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ENDIF + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ELSEIF ( irenuc == 7 ) THEN !} { + + ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + cn(mgs) = 0.0 +! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation + IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 +! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN + ! prevent this branch from activating more than 70% of CCN + CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) ) +! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) + ! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) +!! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN +! IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN +! CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) '1: cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) +! ENDIF + + + ELSE ! }{ + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + +! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN + IF ( ssf(mgs) <= 1.0 ) THEN + CN(mgs) = cnuc(mgs)*Min(1.0, Max(0.0,ssf(mgs))**cck ) ! + ELSE + CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) ! +! write(0,*) 'iren7: ssf,ssmx = ',ssf(mgs),ssmax(mgs),cn(mgs),ccna(mgs),cnuc(mgs) +! write(0,*) 'c1,qv = ',c1,qx(mgs,lv),temp1,ltemq + ENDIF + + ! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) + ! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs) +! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN + IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN + CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) + ENDIF + + +! CN(mgs) = Min( Min(0.1,ssf(mgs)-1.)*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from +! CN(mgs) = Min( Min(0.5*cx(mgs,lc), Min(0.1,ssf(mgs)/100.)*cnuc(mgs)), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from + + CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from + + ENDIF ! } +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + + IF ( icnuclimit > 0 ) THEN +! max droplet conc. based on Chandrakar et al. (2016) and Konwar et al. (2012) + tmp = ccnc(mgs) - ccna(mgs) + cx(mgs,lc) + IF ( tmp < 330.34e6 ) THEN + ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 + ELSE + ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 + ENDIF + + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) + + ENDIF + + IF ( cn(mgs) + cnuf(mgs) > 0.0 ) THEN + + dcrit = 2.0*2.0e-6 + dcloud = 1000.*dcrit**3*Pi/6. + ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass + ! check new droplet size: + ! tmp is number of droplets at diameter dcrit + tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) + cn(mgs) = Min(tmp, cn(mgs) ) + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + cnuf(mgs) + + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + + dcrit = 2.0*2.5e-7 + dcloud = 1000.*dcrit**3*Pi/6.*(cn(mgs) + cnuf(mgs) ) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) + ENDIF + + ELSEIF ( irenuc == 8 ) THEN !} { + ! simple Twomey scheme +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + + cn(mgs) = 0.0 + + IF ( ccnc(mgs) > 0. ) THEN + CN(mgs) = CCNE0*ccnc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + + ELSEIF ( cx(mgs,lc) < 0.01e9 ) THEN + + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + +! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN + IF ( ssf(mgs) <= 1.0 ) THEN + CN(mgs) = 0.0 + ELSE +! CN(mgs) = 0.01e9*rho0(mgs)/rho00*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! + CN(mgs) = 0.01e9*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! + ENDIF + + ENDIF + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF + + + + ENDIF ! } + + ccna(mgs) = ccna(mgs) + cn(mgs) + + + + ENDIF ! irenuc >= 0 .and. .not. flag_qndrop + + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. + GO TO 631 +!.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT + + 613 CONTINUE + + 631 CONTINUE + +! +! Check for supersaturation greater than ssmx and adjust down +! + ssmx = maxsupersat + qv1 = qv0(mgs) + qwvp(mgs) + qvs1 = qvs(mgs) + +! IF ( flag_qndrop .and. do_satadj_for_wrfchem ) ssmx = 1.04 ! set lower threshold for progn=1 when using WRF-CHEM + + IF ( qv1 .gt. (ssmx*qvs1) ) THEN +! use line below to disable saturation adjustment when flag_qndrop is true +! IF ( qv1 .gt. (ssmx*qvs1) .and. .not. flag_qndrop ) THEN + + ss1 = qv1/qvs1 + + ssmx = 100.*(ssmx - 1.0) + + qvex = 0.0 + + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + + + + IF ( qvex .gt. 0.0 ) THEN + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp + ENDIF + qwvp(mgs) = qwvp(mgs) - qvex + qx(mgs,lc) = qx(mgs,lc) + qvex + IF ( .not. flag_qndrop) THEN + IF ( imaxsupopt == 1 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, xmas(mgs,lc) ) ) + ELSEIF ( imaxsupopt == 2 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas30,xmas(mgs,lc)) ) ) + ELSEIF ( imaxsupopt == 3 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmasx,xmas(mgs,lc)) ) ) +! cn(mgs) = 1.5*cxmin + ELSEIF ( imaxsupopt == 4 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) + ENDIF + ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ENDIF + +! write(iunit,*) 'theta = ',theta0(mgs) + thetap(mgs) + +! temg(mgs) = theta(mgs)*( pres(mgs) / poo ) ** cap + + ENDIF + + + ENDIF + +! +! Calculate droplet volume and check if it is within bounds. +! Adjust if necessary +! +! if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: check droplet volume" + + +! cx(mgs,lc) = Min( cwnccn(mgs), cx(mgs,lc) ) + IF( cx(mgs,lc) > cxmin .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN +! SVC(mgs) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)*xdn(mgs,lc)) + xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)) + + IF ( xmas(mgs,lc) < cwmasn .or. xmas(mgs,lc) > cwmasx ) THEN + tmp = cx(mgs,lc) + xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx ) + xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn ) + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + ENDIF + ENDIF + + +! IF( cx(mgs,lc) .GT. 10.e6 .AND. qx(mgs,lc) .GT. qxmin(lc) ) GO TO 681 +! ccwtmp = cx(mgs,lc) +! cwmastmp = xmas(mgs,lc) +! xmas(mgs,lc) = Max(xmas(mgs,lc), cwmasn) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. cx(mgs,lc) .le. 0.) THEN +! cx(mgs,lc) = Min(0.5*cwccn,rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)) +! xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! ENDIF +! IF (cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .GT. qxmin(lc)) & +! & xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .LT. cwmasn) & +! & xmas(mgs,lc) = cwmasn +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .GT. cwmasx) & +! & xmas(mgs,lc) = cwmasx +! IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN +! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc)) +! ENDIF +! +! +! 681 CONTINUE + + + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + + + IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr)) & + & xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr) + IF (xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr) + + ENDIF + + + + ENDDO ! mgs + + +! ################################################################ + DO mgs=1,ngscnt + IF ( lss > 1 .and. ssf(mgs) .gt. ssmax(mgs) & + & .and. ( idecss .eq. 0 .or. qx(mgs,lc) .gt. qxmin(lc)) ) THEN + ssmax(mgs) = ssf(mgs) + ENDIF + ENDDO +! + + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qv0(mgs) + qwvp(mgs) +! tmp3d(igs(mgs),jy,kgs(mgs)) = tmp3d(igs(mgs),jy,kgs(mgs)) + t9(igs(mgs),jy,kgs(mgs)) ! pi0(mgs) ! wvdf(mgs) ! ssf(mgs) ! cn(mgs) +! + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF + + if ( ido(lc) .eq. 1 ) then + an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) + & + & min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 ) +! qx(mgs,lc) = an(igs(mgs),jy,kgs(mgs),lc) + end if +! + + if ( ido(lr) .eq. 1 .and. rcond == 2 ) then + an(igs(mgs),jy,kgs(mgs),lr) = qx(mgs,lr) + & + & min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 ) +! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) + end if + + + + IF ( ipconc .ge. 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) + IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) ) + IF ( lccn .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + IF ( lccnuf .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) ) + ENDIF + IF ( lccna .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccna) = Max(0.0, ccna(mgs) ) + ENDIF + ENDIF + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0) + ENDIF + end do + + +29998 continue + + + if ( kz .gt. nz-1 .and. ix .ge. nxi) then + if ( ix .ge. nxi ) then + go to 2200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if + + if ( ix .ge. nxi ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if + + 2000 continue ! inumgs + 2200 continue +! +! end of gather scatter (for this jy slice) + + +!#ifdef COMMAS +! GOTO 9999 +!#endif + +! Redistribute inappreciable cloud particles and charge +! +! Redistribution everywhere in the domain... +! + frac = 1.0 ! 0.25 ! 1.0 ! 0.2 +! +! alternate test version for ipconc .ge. 3 +! just vaporize stuff to prevent noise in the number concentrations + + + do kz = 1,nz +! do jy = 1,1 + do ix = 1,nxi + + t0(ix,jy,kz) = an(ix,jy,kz,lt)*t77(ix,jy,kz) + + zerocx(:) = .false. + DO il = lc,lhab + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) + IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. an(ix,jy,kz,lz(il)) < zxmin ) + ELSE + IF ( il == lc ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM) + ELSE + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) + ENDIF + ENDIF + ENDDO + + IF ( lhl .gt. 1 ) THEN + + + if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then + +! IF ( an(ix,jy,kz,lhl) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) + an(ix,jy,kz,lhl) = 0.0 +! ENDIF + + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnhl) = 0.0 + ENDIF + + IF ( lvhl .gt. 1 ) THEN + an(ix,jy,kz,lvhl) = 0.0 + ENDIF + + IF ( lhlw .gt. 1 ) THEN + an(ix,jy,kz,lhlw) = 0.0 + ENDIF + + IF ( lzhl .gt. 1 ) THEN + an(ix,jy,kz,lzhl) = 0.0 + ENDIF + + ELSE + IF ( lvol(lhl) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE ! in case volume is zero but mass is above threshold (should not happen, of course) + tmp = rho_qhl + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + + IF ( tmp .lt. xdnmn(lhl) ) THEN + tmp = Max( xdnmn(lhl), tmp ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + + IF ( tmp .gt. xdnmx(lhl) .and. lhlw .le. 0 ) THEN ! no liquid allowed on hail + tmp = Min( xdnmx(lhl), tmp ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ELSEIF ( tmp .gt. xdnmx(lhl) .and. lhlw .gt. 1 ) THEN ! allow for liquid on hail + fw = an(ix,jy,kz,lhlw)/an(ix,jy,kz,lhl) +! tmpmx = xdnmx(lhl) + fw*(xdnmx(lr) - xdnmx(lhl)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + + tmpmx = xdnmx(lhl)/( 1. - fw*(1. - xdnmx(lhl)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmpmx + ENDIF + +! IF ( tmp .gt. xdnmx(lhl) .and. an(ix,jy,kz,lhlw) .lt. qxmin(lhl) ) THEN +! tmp = Min( xdnmx(lhl), tmp ) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ENDIF + ENDIF + + IF ( lhlw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhlw) .gt. 0.98*an(ix,jy,kz,lhl) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + ENDIF + + ENDIF + + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN + + IF ( lvhl .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl)) + tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohlmn ) THEN + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.) + an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) + ENDIF + + ENDIF +! ELSE ! check mean size here? + + end if + + + + ENDIF !lhl + + + if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then + +! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) + an(ix,jy,kz,lh) = 0.0 +! ENDIF + + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnh) = 0.0 + ENDIF + + IF ( lvh .gt. 1 ) THEN + an(ix,jy,kz,lvh) = 0.0 + ENDIF + + IF ( lhw .gt. 1 ) THEN + an(ix,jy,kz,lhw) = 0.0 + ENDIF + + IF ( lzh .gt. 1 ) THEN + an(ix,jy,kz,lzh) = 0.0 + ENDIF + + ELSE + IF ( lvol(lh) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + tmp = rho_qh + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + + IF ( tmp .lt. xdnmn(lh) ) THEN + tmp = Max( xdnmn(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + + IF ( tmp .gt. xdnmx(lh) .and. lhw .le. 0 ) THEN ! no liquid allowed on graupel + tmp = Min( xdnmx(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ELSEIF ( tmp .gt. xdnmx(lh) .and. lhw .gt. 1 ) THEN ! allow for liquid on graupel + fw = an(ix,jy,kz,lhw)/an(ix,jy,kz,lh) +! tmpmx = xdnmx(lh) + fw*(xdnmx(lr) - xdnmx(lh)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + tmpmx = xdnmx(lh)/( 1. - fw*(1. - xdnmx(lh)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmpmx + ENDIF + +! IF ( tmp .gt. xdnmx(lh) .and. an(ix,jy,kz,lhw) .lt. qxmin(lh) ) THEN +! tmp = Min( xdnmx(lh), tmp ) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ENDIF + + ENDIF + + IF ( lhw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhw) .gt. 0.98*an(ix,jy,kz,lh) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + ENDIF + + ENDIF + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = xdn0(lh) + ENDIF + hwdn = Max( xdnmn(lh), hwdn ) + ELSE + hwdn = xdn0(lh) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh)) + tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohmn ) THEN +! tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) +! tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.) + ENDIF + + ENDIF + + end if + + + if ( an(ix,jy,kz,ls) .lt. frac*qxmin(ls) .or. zerocx(ls) & ! .or. an(ix,jy,kz,lns) .lt. 0.1 ! .and. + & ) then + IF ( t0(ix,jy,kz) .lt. 273.15 ) THEN +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF + + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF + + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF + + ELSE +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF + + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF + + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF + + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lnr) = an(ix,jy,kz,lnr) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + ENDIF + + + ELSEIF ( lvol(ls) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + IF ( tmp .gt. xdnmx(ls) .or. tmp .lt. xdnmn(ls) ) THEN + tmp = Min( xdnmx(ls), Max( xdnmn(ls), tmp ) ) + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF + ELSE + tmp = rho_qs + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF + + + end if + + + if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & + & ) then + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) + an(ix,jy,kz,lr) = 0.0 + IF ( ipconc .ge. 3 ) THEN +! an(ix,jy,kz,lnc) = an(ix,jy,kz,lnc) + an(ix,jy,kz,lnr) + an(ix,jy,kz,lnr) = 0.0 + ENDIF + + end if + +! +! for qci +! + IF ( an(ix,jy,kz,li) .le. frac*qxmin(li) .or. zerocx(li) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) + an(ix,jy,kz,li)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lni) = 0.0 + ENDIF + ENDIF + +! +! for qis +! + IF ( lis > 1 ) THEN ! { + IF ( an(ix,jy,kz,lis) .le. frac*qxmin(lis) .or. zerocx(lis) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN ! { { + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis) + an(ix,jy,kz,lis)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lnis) = 0.0 + ENDIF + + ELSEIF ( icespheres >= 2 ) THEN ! } { + km1 = Max(1, kz-1) + IF ( 0.5*( w(ix,jy,kz) + w(ix,jy,kz+1)) < -1.0 .or. & + & (icespheres == 3 .and. ( t0(ix,jy,kz) < 232.15 .or. an(ix,jy,kz,lc) < qxmin(lc) ) ) .or. & + & (icespheres == 5 .and. ( t0(ix,jy,kz) < 232.15 .or. & + & ( an(ix,jy,kz,lc) < qxmin(lc) .and. an(ix,jy,km1,lc) < qxmin(lc) )) ) .or. & + & (icespheres == 4 .and. ( t0(ix,jy,kz) < 235.15 )) ) THEN ! transfer to regular ice crystals in downdraft or at low temp + an(ix,jy,kz,li) = an(ix,jy,kz,li) + an(ix,jy,kz,lis) + an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lnis) + an(ix,jy,kz,lis)= 0.0 + an(ix,jy,kz,lnis)= 0.0 + + ENDIF + + ENDIF ! } } + ENDIF ! } + +! +! for qcw +! + + IF ( an(ix,jy,kz,lc) .le. frac*qxmin(lc) .or. zerocx(lc) & + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) + an(ix,jy,kz,lc)= 0.0 + IF ( ipconc .ge. 2 ) THEN + IF ( lccn .gt. 1 ) THEN + an(ix,jy,kz,lccn) = & + & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ENDIF + an(ix,jy,kz,lnc) = 0.0 + + IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) + + IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) + + ELSEIF ( lccn > 1 .and. restoreccn ) THEN + ! in this case, we are treating the ccn field as ccna + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) +! IF ( ny == 2 .and. ix == nx/2 ) THEN +! write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst) +! write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) +! ENDIF + IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) ) THEN + ! an(ix,jy,kz,lccn) = & + ! an(ix,jy,kz,lccn) + Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst)) + ! Equivalent form after expanding last term: + an(ix,jy,kz,lccn) = & + dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) + ENDIF + + ENDIF + + ENDIF + + ENDIF + + end do +! end do + end do + + + IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' +! +! + + + 9999 RETURN + + END SUBROUTINE NUCOND + + +! ##################################################################### +! ##################################################################### + + + + +!c-------------------------------------------------------------------------- +! +! +!-------------------------------------------------------------------------- +! + + subroutine nssl_2mom_gs & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,dtp,gz & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn,p2 & + & ,pn,w,iunit & + & ,t00,t77, & + & ventr,ventc,c1sw,jgs,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & + & cdx, & + & xdn0,tmp3d,tkediss & + & ,timevtcalc,axtra,io_flag & + & ,rainprod2d, evapprod2d & + & ,elec,its,ids,ide,jds,jde & + & ) + + +! +!-------------------------------------------------------------------------- +! +! Ziegler 1985 parameterized microphysics (also Zrnic et al. 1993) +! 1) cloud water +! 2) rain +! 3) column ice +! 6) snow +! 11) graupel/hail +! +!-------------------------------------------------------------------------- +! +! Notes: +! +! 4/27/2009: allows for liquid water to be advected on snow and graupel particles using flag "mixedphase" +! +! 3/14/2007: (APS) added qproc temp to make microphysic process timeseries +! +! 10/17/2006: added flag (iehw) to select how to calculate ehw +! +! 10/5/2006: switched chacr to integrated version rather than assuming that average rain +! drop mass does not change. This acts to reduce rain size somewhat via graupel +! collection. +! Use Mason data for ehw, with scaling toward ehw=1 as air density decreases. +! +! 10/3/2006: Turned off Meyers nucleation for T > -5 (can turn on with imeyers5 flag) +! Turned off contact nucleation in updrafts +! +! 7/24/2006: Turned on Meyers nucleation for -5 < T < 0 +! +! 5/12/2006: Converted qsacw/csacw and qsaci/csaci to Z93 +! +! 5/12/2006: Put a threshold on Bigg rain freezing. If the frozen drops +! have an average volume less than xvhmn, then the drops are put +! into snow instead of graupel/hail. +! +! Fixed bug when vapor deposition was limited. +! +! 5/13/2006: Note that qhacr has a large effect, but Z85 did not include it. +! Turned off qsacr (set to zero). +! +! 9/14/2007: erm: recalculate vx(lh) after setting xdn(lh) in case xdn was out of allowed range. +! added parameter rimc3 for minimum rime density. Default value set at 170. kg/m**3 +! instead of previous use of 100. (Farley, 1987) +! +!-------------------------------------------------------------------------- +! +! general declarations +! +!-------------------------------------------------------------------------- +! +! +! + + + implicit none +! +! integer icond +! parameter ( icond = 2 ) + + integer, parameter :: ng1 = 1 + + integer nx,ny,nz,na,nba,nv + integer nor,norz,istag,jstag,kstag ! ,nht,ngt,igsr + integer iwrite + real dtp,dx,dy,dz + + logical, intent(in) :: io_flag + + integer itile,jtile,ktile + integer ixbeg,jybeg + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + integer :: my_rank = 0 + integer, parameter :: myprock = 1, nprock = 1 + real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + + real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + + real :: galpharaut + real :: xvbarmax + + integer jyslab,its,ids,ide,jds,jde ! domain boundaries + integer, intent(in) :: iunit !,iunit0 + real qvex + integer iraincv, icgxconv + parameter ( iraincv = 1, icgxconv = 1) + real ffrz + + real qcitmp,cirdiatmp ! ,qiptmp,qirtmp + real ccwtmp,ccitmp ! ,ciptmp,cirtmp + real cpqc,cpci ! ,cpip,cpir + real cpqc0,cpci0 ! ,cpip0,cpir0 + real scfac ! ,cpip1 + + double precision dp1 + + double precision frac, frach, xvfrz + + double precision :: timevtcalc + double precision :: dpt1,dpt2 + + logical, parameter :: gammacheck = .false. + integer :: luindex + double precision :: tmpgam + logical, parameter :: usegamxinfcnu = .false. + logical, parameter :: usegamxinf = .false. + logical, parameter :: usegamxinf2 = .false. + logical, parameter :: usegamxinf3 = .false. +! real rar ! rime accretion rate as calculated from qxacw + + +! a few vars for time-split fallout + real vtmax + integer n,ndfall + + double precision chgneg,chgpos,sctot + + real temgtmp + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + + real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! dz + + real qimax,xni0,roqi0 + + + real dv + + real dtptmp + integer itest,nidx,id1,jd1,kd1 + parameter (itest=1) + parameter (nidx=10) + parameter (id1=1,jd1=1,kd1=1) + integer ierr + integer iend + + integer ix,kz, il, ic, ir, icp1, irp1, ip1,jp1,kp1 + integer :: jy + integer i,j,k,i1 + integer kzb,kze + real slope1, slope2 + real x1, x2, x3 + real eps,eps2 + parameter (eps=1.e-20,eps2=1.e-5) +! +! Other elec. vars +! + real temele + real trev + + logical ldovol, ishail, ltest, wtest + logical , parameter :: alp0flag = .false. +! +! +! wind indicies +! + integer mu,mv,mw + parameter (mu=1,mv=2,mw=3) +! +! conversion parameters +! + integer mqcw,mqxw,mtem,mrho,mtim + parameter (mqcw=21,mqxw=21,mtem=21,mrho=5,mtim=6) + + real xftim,xftimi,yftim, xftem,yftem, xfqcw,yfqcw, xfqxw,yfqxw + parameter (xftim=0.05,xftimi = 1./xftim,yftim=1.) + parameter (xftem=0.5,yftem=1.) + parameter (xfqcw=2000.,yfqcw=1.) + parameter (xfqxw=2000.,yfqxw=1.) + real dtfac + parameter ( dtfac = 1.0 ) + integer ido(lc:lqmx) + +! integer iexy(lc:lqmx,lc:lqmx) +! integer ieswi, ieswir, ieswip, ieswc, ieswr +! integer ieglsw, iegli, ieglir, ieglip, ieglc, ieglr +! integer iegmsw, iegmi, iegmir, iegmip, iegmc, iegmr +! integer ieghsw, ieghi, ieghir, ieghip, ieghc, ieghr +! integer iefwsw, iefwi, iefwir, iefwip, iefwc, iefwr +! integer iehwsw, iehwi, iehwir, iehwip, iehwc, iehwr +! integer iehlsw, iehli, iehlir, iehlip, iehlc, iehlr +! real delqnsa, delqxsa, delqnsb, delqxsb, delqnia, delqxia +! real delqnra, delqxra + + real delqnxa(lc:lqmx) + real delqxxa(lc:lqmx) +! +! external temporary arrays +! + real t00(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t77(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t1(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t3(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t4(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t5(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t6(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + + real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + +! +! declarations microphyscs and for gather/scatter +! + integer nxmpb,nzmpb,nxz + integer jgs,mgs,ngs,numgs + parameter (ngs=500) !500) + integer, parameter :: ngsz = 500 + integer ntt + parameter (ntt=300) + + real dvmgs(ngs) + + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs),kgsm2(ngs) + integer ncuse + parameter (ncuse=0) + integer il0(ngs),il5(ngs),il2(ngs),il3(ngs) +! integer il1m(ngs),il2m(ngs),il3m(ngs),il4m(ngs),il5m(ngs) +! + real tdtol,temsav,tfrcbw,tfrcbi + real, parameter :: thnuc = 235.15 +! +! Ice Multiplication Arrays. +! + real fimt1(ngs),fimta(ngs),fimt2(ngs) !,qmul1(ngs),qmul2(ngs) + real xcwmas +! +! +! Variables for Ziegler warm rain microphysics +! + + + real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs) + real cwnccn(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor, tmpdiam + real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter (same as area-weighted diameter), 4 for mass-weighted diameter + real ssmax(ngs) ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real bfnu, bfnu0, bfnu1 + parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0) ) + real ventr, ventc + real volb, aa1, aa2 + double precision t2s, xdp + double precision xl2p(ngs),rb(ngs) + parameter ( aa1 = 9.44e15, aa2 = 5.78e3 ) ! a1 in Ziegler +! snow parameters: + real cexs, cecs + parameter ( cexs = 0.1, cecs = 0.5 ) + real rvt ! ratio of collection kernels (Zrnic et al, 1993) + parameter ( rvt = 0.104 ) + real kfrag ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) + parameter ( kfrag = 1.0e-6 ) + real mfrag ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) + parameter ( mfrag = 1.0e-10) + double precision cautn(ngs), rh(ngs), nh(ngs) + real ex1, ft, rhoinv(ngs) + double precision ec0(ngs) + + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super + real dw,dwr + double precision :: tmpz, tmpzmlt + real ratio, delx, dely + real dbigg,volt + real chgtmp,fac,mixedphasefac + real x,y,y2,del,r,rtmp,alpr + double precision :: vent1,vent2 + double precision :: g1palp,g4palp + double precision :: g1palpinf,g4palpinf + real fqt !charge separation as fn of temperature from Dong and Hallett 1992 + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + real c1sw ! integration factor for snow melting with snu = -0.8 + real, parameter :: vr1mm = 5.23599e-10 ! volume of 1mm diameter sphere (m**3) + real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3 ! volume of a 3 mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 ! volume of 4.5mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real vmlt,vshd, vshdgs(ngs,lh:lhab), maxmassfac(lc:lhab) + real rhosm + parameter ( rhosm = 500. ) + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real cn(ngs) + double precision xvc, xvr + real mwfac +! real es(ngs) ! ss(ngs), +! real eis(ngs) + + real rwmasn,rwmasx + + real vgra,vfrz + parameter ( vgra = 0.523599*(1.0e-3)**3 ) + +! real, parameter :: epsi = 0.622 +! real, parameter :: d = 0.266 + real :: d, dold, denom,denominv,vth + double precision :: h1, h2, h3, h4,denomdp, denominvdp + real r1,qevap ! ,slv + + real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia,rmas + real :: snowmeltmass = 0 + + real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain + real, parameter :: rimedens = 500. ! default rime density + +! real svc(ngs) ! droplet volume +! +! contact freezing nucleation +! + real raero,kaero !assumd aerosol radius, thermal conductivity + parameter ( raero = 3.e-7, kaero = 5.39e-3 ) + real kb ! Boltzman constant J K-1 + parameter (kb = 1.3807e-23) + + real knud(ngs),knuda(ngs) !knudsen number and correction factor + real gtp(ngs) !G(T,p) = 1/(a' + b') Cotton 72b + real dfar(ngs) !aerosol diffusivity + real fn1(ngs),fn2(ngs),fnft(ngs) + + real ccia(ngs) + real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs) +! +! misc +! + real ni,nis,nr,d0 + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs),dqcitmp(ngs),dqwvtmp(ngs) + real tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) + real temgkm1(ngs), temgkm2(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real elv(ngs),elf(ngs),els(ngs) + real tsqr(ngs),ssi(ngs),ssw(ngs) + real qcwtmp(ngs),qtmp,qtot(ngs) + real qcond(ngs) + real ctmp, sctmp + real cimasn,cimasx,ccimx + real pid4 + real cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1 + real gcnup1,gcnup2 + real gf73rds, gf83rds + real gamice73fac, gamsnow73fac + real gf43rds, gf53rds + real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn + parameter ( rwradmn = 50.e-6 ) + real dh0 + real dg0(ngs) + + real clionpmx,clionnmx + parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 +! +! other arrays + + real fwet1(ngs),fwet2(ngs) + real fmlt1(ngs),fmlt2(ngs) + real fvds(ngs),fvce(ngs),fiinit(ngs) + real fvent(ngs),fraci(ngs),fracl(ngs) +! + real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs) + real felv(ngs),fels(ngs),felf(ngs) + real felvcp(ngs),felscp(ngs),felfcp(ngs) + real felvpi(ngs),felspi(ngs),felfpi(ngs) + real felvs(ngs),felss(ngs) ! ,felfs(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) ! heat capacities of ice and liquid + real fschm(ngs),fpndl(ngs) + real fgamw(ngs),fgams(ngs) + real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) + + real cvm,cpm,rmm + + real, parameter :: rovcp = rd/cp + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure +! + real fcci(ngs), fcip(ngs) +! + real :: sfm1(ngs),sfm2(ngs) + real :: gfm1(ngs),gfm2(ngs) + real :: hfm1(ngs),hfm2(ngs) + + logical :: wetsfc(ngs),wetsfchl(ngs) + logical :: wetgrowth(ngs), wetgrowthhl(ngs) + + real qitmp(ngs),qistmp(ngs) + + real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs) + real rzxs(ngs) + real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs),cdh(ngs),cdhl(ngs) + real vt2ave(ngs) + + real :: qcwresv(ngs), ccwresv(ngs) ! "reserved" droplet mass and number that are too small for accretion + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: qxwlg(ngs,lh:lhab) + real :: cx(ngs,lc:lhab) + real :: cxmxd(ngs,lc:lhab) + real :: qxmxd(ngs,lv:lhab) + real :: scx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: cdxgs(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vtwtdia(ngs,lr:lhab) ! sweep-out volume weighted diameter + real :: rarx(ngs,ls:lhab) + real :: vx(ngs,li:lhab) + real :: rimdn(ngs,li:lhab) + real :: raindn(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: dab0lh(ngs,lc:lhab,lr:lhab) + real :: dab1lh(ngs,lc:lhab,lr:lhab) + + real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis + real :: qsimxsub(ngs) ! max depositionof qi+qs+qis + logical,parameter :: DoSublimationFix = .true. + real :: qrtmp(ngs),qvtmp(ngs),qctmp(ngs) + real :: felvcptmp,felscptmp,qsstmp + real :: thetatmp, thetaptmp, temcgtmp,qvaptmp + real :: qvstmp, qisstmp, qvptmp, qitmp1, qctmp1 + + real :: galphrout + + real ventrx(ngs) + real ventrxn(ngs) + real g1shr, alphashr + real g1mlr, alphamlr + real massfacshr, massfacmlr + + real :: qhgt8mm ! ice mass greater than 8mm + real :: qhwgt8mm ! ice + max water mass greater than 8mm + real :: qhgt10mm ! mass greater than 10mm + real :: qhgt20mm ! mass greater than 20mm + real :: fwmhtmp + real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles + real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) ! d1t is the diameter of the ice sphere with the mass (0.268e-3 kg) of an 8mm spherical drop + real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield +! + real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) + integer, parameter :: ndiam = 10 + integer :: numdiam + real hwvent0(ndiam+4),hlvent0 ! 0 to d1 + real hwvent1,hlvent1 ! d1 to infinity + real hwvent2,hlvent2 ! d2 to infinity + real gama0,gamb0 + real gama1,gamb1 + real gama2,gamb2 +! real, parameter :: mltdiam1 = 9.0e-3, mltdiam1p5 = 16.0e-3, mltdiam2 = 19.0e-3, mltdiam3 = 200.0e-3, mltdiam05 = 4.5e-3 + real :: mltdiam(ndiam+4) + real mltmass0inv,mltmass1inv,mltmass2inv, mltmass1cgs, mltmass2cgs,mltmass3inv, mltmass3cgs + real qhmlr0, qhmlr05, qhmlr1, qhmlr2,qhmlr3, qhmlr12, qhmlr23 + real qhlmlr0, qhlmlr05, qhlmlr1, qhlmlr2,qhlmlr3, qhlmlr12, qhlmlr23 + real qxd1, cxd1, zxd1 ! mass and number up to mltdiam1 + real qxd05, cxd05 ! mass and number up to mltdiam1/2 + + real :: qxd(ndiam+4), cxd(ndiam+4), qhml(ndiam+4), qhml0(ndiam+4) + real :: dqxd(ndiam+4), dcxd(ndiam+4), dqhml(ndiam+4) + + + real civent(ngs) + real isvent(ngs) +! + real xmascw(ngs) + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real dnmx + real :: xdiamxmas(ngs,lc:lhab) +! + real cilen(ngs) ! ,ciplen(ngs) +! +! + real rwcap(ngs),swcap(ngs) + real hwcap(ngs) + real hlcap(ngs) + real cicap(ngs) + real iscap(ngs) + + real qvimxd(ngs) + real qimxd(ngs),qismxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) + real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs) + real cionpmxd(ngs),cionnmxd(ngs) + real clionpmxd(ngs),clionnmxd(ngs) + + + real elec(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! Ez (elecsave) + +! +! + ! Hallett-Mossop arrays + real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs) + real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs) + + ! splinters from drop freezing + real csplinter(ngs),qsplinter(ngs) + real csplinter2(ngs),qsplinter2(ngs) +! +! +! concentration arrays... +! + real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs) + real :: chlcnhhl(ngs) ! number of new hail particles (may be different from number of lost graupel) + real cracif(ngs), ciacrf(ngs) + real cracr(ngs) + +! + real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs) + real cicint(ngs) + real cipint(ngs) + real ciacw(ngs), cwacii(ngs) + real ciacr(ngs), craci(ngs) + real csacw(ngs) + real csacr(ngs) + real csaci(ngs), csacs(ngs) + real cracw(ngs) + real chacw(ngs), chacr(ngs) + real :: chlacw(ngs) ! = 0.0 + real chaci(ngs), chacs(ngs) +! + real :: chlacr(ngs) + real :: chlaci(ngs), chlacs(ngs) + real crcnw(ngs) + real cidpv(ngs),cisbv(ngs) + real cisdpv(ngs),cissbv(ngs) + real cimlr(ngs),cismlr(ngs) + + real chlsbv(ngs), chldpv(ngs) + real chlmlr(ngs), chlmlrr(ngs) +! real chlmlrsave(ngs),chlsave(ngs),qhlsave(ngs) + real chlshr(ngs), chlshrr(ngs) + + + real chdpv(ngs),chsbv(ngs) + real chmlr(ngs),chcev(ngs) + real chmlrr(ngs) + real chshr(ngs), chshrr(ngs) + + real csdpv(ngs),cssbv(ngs) + real csmlr(ngs),csmlrr(ngs),cscev(ngs) + real csshr(ngs), csshrr(ngs) + + real crcev(ngs) + real crshr(ngs) +! +! +! arrays for w-ac-x ; x-ac-w +! +! +! + real qrcnw(ngs), qwcnr(ngs) + real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) + + + real qracw(ngs) ! qwacr(ngs), + real qiacw(ngs) !, qwaci(ngs) + + real qsacw(ngs) ! ,qwacs(ngs), + real qhacw(ngs) ! qwach(ngs), + real :: qhlacw(ngs) ! = 0.0 + real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + +! + real qsacws(ngs) + +! +! arrays for x-ac-r and r-ac-x; +! + real qsacr(ngs),qracs(ngs) + real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs) + real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) + real qiacr(ngs),qraci(ngs) + + real ziacr(ngs) + + real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) + + real :: qhlacr(ngs),qhlacrmlr(ngs) ! = 0.0 + real qsacrs(ngs) !,qracss(ngs) +! +! ice - ice interactions +! + real qsaci(ngs) + real qsacis(ngs) + real qhaci(ngs) + real qhacs(ngs) + + real :: qhacis(ngs) = 0.0 + real :: chacis(ngs) = 0.0 + real :: chacis0(ngs) = 0.0 + + real :: csaci0(ngs) ! collision rate only + real :: chaci0(ngs) ! collision rate only + real :: chacs0(ngs) ! collision rate only + real :: chlaci0(ngs) ! = 0.0 + real :: chlacis(ngs) = 0.0 + real :: chlacis0(ngs) = 0.0 + real :: chlacs0(ngs) ! = 0.0 + + real :: qsaci0(ngs) ! collision rate only + real :: qsacis0(ngs) ! collision rate only + real :: qhaci0(ngs) ! collision rate only + real :: qhacis0(ngs) ! collision rate only + real :: qhacs0(ngs) ! collision rate only + real :: qhlaci0(ngs) ! = 0.0 + real :: qhlacis0(ngs) ! = 0.0 + real :: qhlacs0(ngs) ! = 0.0 + + real :: qhlaci(ngs) ! = 0.0 + real :: qhlacis(ngs) ! = 0.0 + real :: qhlacs(ngs) ! = 0.0 +! +! conversions +! + real qrfrz(ngs) ! , qirirhr(ngs) + real zrfrz(ngs), zrfrzf(ngs), zrfrzs(ngs) + real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) + real zhacw(ngs), zhacs(ngs), zhaci(ngs) + real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs) + real zhmlrtmp,zhmlr0inf,zhlmlr0inf + real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs) + real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) + real zhcns(ngs), zhcni(ngs) + real zhwdn(ngs) ! change in Z due to density changes + real zhldn(ngs) ! change in Z due to density changes + + real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs) + real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs) + + + real vrfrzf(ngs), viacrf(ngs) + real qrfrzs(ngs), qrfrzf(ngs) + real qwfrz(ngs), qwctfz(ngs) + real cwfrz(ngs), cwctfz(ngs) + real qwfrzis(ngs), qwctfzis(ngs) ! droplet freezing to ice spheres + real cwfrzis(ngs), cwctfzis(ngs) + real qwfrzc(ngs), qwctfzc(ngs) ! droplet freezing to columns + real cwfrzc(ngs), cwctfzc(ngs) + real qwfrzp(ngs), qwctfzp(ngs) ! droplet freezing to plates + real cwfrzp(ngs), cwctfzp(ngs) + real xcolmn(ngs), xplate(ngs) + real ciihr(ngs), qiihr(ngs) + real cicichr(ngs), qicichr(ngs) + real cipiphr(ngs), qipiphr(ngs) + real qscni(ngs), cscni(ngs), cscnis(ngs) + real qscnvi(ngs), cscnvi(ngs), cscnvis(ngs) + real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs) + real qscnh(ngs), cscnh(ngs), vscnh(ngs) + real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs) + real qiint(ngs),qipipnt(ngs),qicicnt(ngs) + real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs) + real tke(ngs) + real uvel(ngs),vvel(ngs) +! + real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs), + real qimlr(ngs),qidsv(ngs),qisdsv(ngs),qidsvp(ngs) ! ,qicev(ngs) + real qismlr(ngs) + +! + real qfdpv(ngs),qfsbv(ngs) ! qfcnv(ngs),qfevv(ngs), + real qfmlr(ngs),qfdsv(ngs) ! ,qfcev(ngs) + real qfwet(ngs),qfdry(ngs),qfshr(ngs) + real qfshrp(ngs) +! + real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), + real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) + real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) +! + real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs) +! + real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs), + real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) + real qhlcev(ngs), chlcev(ngs) + real qhwet(ngs),qhdry(ngs),qhshr(ngs) + real qhshrp(ngs) + real qhshh(ngs) !accreted water that remains on graupel + real qhmlh(ngs) !melt water that remains on graupel + real qhfzh(ngs) !water that freezes on mixed-phase graupel + real qhlfzhl(ngs) !water that freezes on mixed-phase hail + + real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters + real qhfzhlg(ngs) !water that freezes on mixed-phase graupel (large sizes) + real qhlfzhllg(ngs) !water that freezes on mixed-phase hail (large sizes) + real qhlcevlg(ngs), chlcevlg(ngs) + real qhcevlg(ngs), chcevlg(ngs) + + real vhfzh(ngs) ! change in volume from water that freezes on mixed-phase graupel + real vhlfzhl(ngs) ! change in volume from water that freezes on mixed-phase hail + + real vhshdr(ngs) !accreted water that leaves on graupel (mixedphase) + real vhlshdr(ngs) !accreted water that leaves on hail (mixedphase) + real vhmlr(ngs) !melt water that leaves graupel (single phase) + real vhlmlr(ngs) !melt water that leaves hail (single phase) + real vhsoak(ngs) ! aquired water that seeps into graupel. + real vhlsoak(ngs) ! aquired water that seeps into hail. +! + real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs), + real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs) + real qswet(ngs),qsdry(ngs),qsshr(ngs) + real qsshrp(ngs) + real qsfzs(ngs) +! +! + real qipdpv(ngs),qipsbv(ngs) + real qipmlr(ngs),qipdsv(ngs) +! + real qirdpv(ngs),qirsbv(ngs) + real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs) +! + real qgldpv(ngs),qglsbv(ngs) + real qglmlr(ngs),qgldsv(ngs) + real qglwet(ngs),qgldry(ngs),qglshr(ngs) + real qglshrp(ngs) +! + real qgmdpv(ngs),qgmsbv(ngs) + real qgmmlr(ngs),qgmdsv(ngs) + real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs) + real qgmshrp(ngs) + real qghdpv(ngs),qghsbv(ngs) + real qghmlr(ngs),qghdsv(ngs) + real qghwet(ngs),qghdry(ngs),qghshr(ngs) + real qghshrp(ngs) +! + real qrztot(ngs),qrzmax(ngs),qrzfac(ngs) + real qrcev(ngs) + real qrshr(ngs) + real fsw(ngs),fhw(ngs),fhlw(ngs) !liquid water fractions + real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions + real qhcnf(ngs) + real :: qhlcnh(ngs) ! = 0.0 + real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) + + real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel + + real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs),eisw(ngs) + real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs) + real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) + real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) + real ehxr(ngs),ehlr(ngs),egmr(ngs) + real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs) + real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) + real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) + real ehscnv(ngs) + real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) + + real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) + real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs) + real esiclsn(ngs) + + real :: ehs_collsn = 0.5, ehi_collsn = 1.0 + real :: ehls_collsn = 1.0, ehli_collsn = 1.0 + real :: esi_collsn = 1.0 + + real ew(8,6) + real cwr(8,2) ! radius and inverse of interval + data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & ! radius + & 1.0, 1.0, 0.5, 0.5, 0.5, 0.2, 0.2, 1. / ! inverse of interval + integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs) + real grad(6,2) ! graupel radius and inverse of interval + data grad / 100., 200., 300., 400., 600., 1000., & + & 1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1. / +!droplet radius: 2 3 4 6 8 10 15 20 + data ew /0.03, 0.07, 0.17, 0.41, 0.58, 0.69, 0.82, 0.88, & ! 100 +! : 0.07, 0.13, 0.27, 0.48, 0.65, 0.73, 0.84, 0.91, ! 150 + & 0.10, 0.20, 0.34, 0.58, 0.70, 0.78, 0.88, 0.92, & ! 200 + & 0.15, 0.31, 0.44, 0.65, 0.75, 0.83, 0.96, 0.91, & ! 300 + & 0.17, 0.37, 0.50, 0.70, 0.81, 0.87, 0.93, 0.96, & ! 400 + & 0.17, 0.40, 0.54, 0.71, 0.83, 0.88, 0.94, 0.98, & ! 600 + & 0.15, 0.37, 0.52, 0.74, 0.82, 0.88, 0.94, 0.98 / ! 1000 +! : 0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400 + + + real da0lr(ngs) + real da0lh(ngs) + real da0lhl(ngs) + + real va0 (lc:lqmx) ! collection coefficients from Seifert 2005 + real vab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real vab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real va1 (lc:lqmx) ! collection coefficients from Seifert 2005 + real ehip(ngs),ehlip(ngs),ehlir(ngs) + real erir(ngs),esir(ngs),eglir(ngs),egmir(ngs),eghir(ngs) + real efir(ngs),ehir(ngs),eirw(ngs),eirir(ngs),ehr(ngs) + real erip(ngs),esip(ngs),eglip(ngs),eghip(ngs) + real efip(ngs),eipi(ngs),eipw(ngs),eipip(ngs) +! +! arrays for production terms +! + real ptotal(ngs) ! , pqtot(ngs) +! + real pqcwi(ngs),pqcii(ngs),pqrwi(ngs),pqisi(ngs) + real pqswi(ngs),pqhwi(ngs),pqwvi(ngs) + real pqgli(ngs),pqghi(ngs),pqfwi(ngs) + real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) + real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), + real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs) + + real pqlwlghi(ngs),pqlwlghli(ngs) + real pqlwlghd(ngs),pqlwlghld(ngs) + + + + real pvhwi(ngs), pvhwd(ngs) + real pvhli(ngs), pvhld(ngs) + real pvswi(ngs), pvswd(ngs) +! + real pqcwd(ngs),pqcid(ngs),pqrwd(ngs),pqisd(ngs), pqcwdacc(ngs) + real pqswd(ngs),pqhwd(ngs),pqwvd(ngs) + real pqgld(ngs),pqghd(ngs),pqfwd(ngs) + real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) + real pqird(ngs),pqipd(ngs) ! pqwad(ngs), + real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs) +! +! real pqxii(ngs,nhab),pqxid(ngs,nhab) +! + real pctot(ngs) + real pcipi(ngs), pcipd(ngs) + real pciri(ngs), pcird(ngs) + real pccwi(ngs), pccwd(ngs), pccwdacc(ngs) + real pccii(ngs), pccid(ngs) + real pcisi(ngs), pcisd(ngs) + real pccin(ngs) + real pcrwi(ngs), pcrwd(ngs) + real pcswi(ngs), pcswd(ngs) + real pchwi(ngs), pchwd(ngs) + real pchli(ngs), pchld(ngs) + real pcfwi(ngs), pcfwd(ngs) + real pcgli(ngs), pcgld(ngs) + real pcgmi(ngs), pcgmd(ngs) + real pcghi(ngs), pcghd(ngs) + + real pzrwi(ngs), pzrwd(ngs) + real pzhwi(ngs), pzhwd(ngs) + real pzhli(ngs), pzhld(ngs) + real pzswi(ngs), pzswd(ngs) + +! +! other arrays +! + real dqisdt(ngs) !,advisc(ngs) !dqwsdt(ngs), ,schm(ngs),pndl(ngs) + + real qss0(ngs) + + real qsacip(ngs) + real pres(ngs),pipert(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs),sqrtrhovt + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real ptwfzi(ngs),ptimlw(ngs) + real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs),ptem2(ngs) + + real cnostmp(ngs) ! for diagnosed snow intercept +! +! iholef = 1 to do hole filling technique version 1 +! which uses all hydrometerors to do hole filling of all hydrometeors +! iholef = 2 to do hole filling technique version 2 +! which uses an individual hydrometeror species to do hole +! filling of a species of a hydrometeor +! +! iholen = interval that hole filling is done +! + integer iholef + integer iholen + parameter (iholef = 1) + parameter (iholen = 1) + real cqtotn,cqtotn1 + real cctotn + real citotn + real crtotn + real cstotn + real cvtotn + real cftotn + real cgltotn + real cghtotn + real chtotn + real cqtotp,cqtotp1 + real cctotp + real citotp + real ciptotp + real crtotp + real cstotp + real cvtotp + real cftotp + real chltotp + real cgltotp + real cgmtotp + real cghtotp + real chtotp + real cqfac + real ccfac + real cifac + real cipfac + real crfac + real csfac + real cvfac + real cffac + real cglfac + real cghfac + real chfac + + real ssifac, qvapor +! +! Miscellaneous variables +! + integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh + integer lqrw + real vt + real arg ! gamma is a function + real erbnd1, fdgt1, costhe1 + real qeps + real dyi2,dzi2,cp608,bta1,cnit,dragh,dnz00,pii + real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds,gr + real gf1palp(ngs) ! for storing Gamma[1.0 + alphar] + + + real xdn0(lc:lhab) + real xdn_new,drhodt + + integer l ,ltemq,inumgs, idelq + + real brz,arz,temq + + real ssival,tqvcon + real cdx(lc:lhab) + real cnox + real cval,aval,eval,fval,gval ,qsign,ftelwc,qconkq,elecfac,altelecfac + real qconm,qconn,cfce15,gf8,gf4i,gf3p5,gf1a,gf1p5,qdiff,argrcnw + real c4,bradp,bl2,bt2,dthr,hrifac, hdia0,hdia1,civenta,civentb + real civentc,civentd,civente,civentf,civentg,cireyn,xcivent + real cipventa,cipventb,cipventc,cipventd,cipreyn,cirventa + real cirventb + integer igmrwa,igmrwb,igmswa, igmswb,igmfwa,igmfwb,igmhwa,igmhwb + real rwventa ,rwventb,swventa,swventb,fwventa,fwventb,fwventc + real hwventa,hwventb + real hwventc, hlventa, hlventb, hlventc + real glventa, glventb, glventc + real gmventa, gmventb, gmventc, ghventa, ghventb, ghventc + real dzfacp, dzfacm, cmassin, cwdiar + real rimmas, rhobar + real argtim, argqcw, argqxw, argtem + real frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1 + real frcglgl, frcglgm, frcglgh, frcglfw, frcglgl1 + real frcgmgl, frcgmgm, frcgmgh, frcgmfw, frcgmgm1 + real frcghgl, frcghgm, frcghgh, frcghfw, frcghgh1 + real frcfwgl, frcfwgm, frcfwgh, frcfwfw, frcfwfw1 + real frcswrsw, frcswrgl, frcswrgm, frcswrgh, frcswrfw + real frcswrsw1 + real frcrswsw, frcrswgl, frcrswgm, frcrswgh, frcrswfw + real frcrswsw1 + real frcglrgl, frcglrgm, frcglrgh, frcglrfw, frcglrgl1 + real frcrglgl + real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 + real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 + real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 + real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt + real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl + real frcrghgm, frcrghgh, frcrghfw, frcrghgh1 + real a1,a2,a3,a4,a5,a6 + real gamss + real cdw, cdi, denom1, denom2, delqci1, delqip1 + real cirtotn, ciptotn, cgmtotn, chltotn, cirtotp + real cgmfac, chlfac, cirfac + integer igmhla, igmhlb, igmgla, igmglb, igmgma, igmgmb + integer igmgha, igmghb + integer idqis, item, itim0 + integer iqgl, iqgm, iqgh, iqrw, iqsw + integer itertd, ia + + integer :: infdo + + real tau, ewtmp + + integer cntnic_noliq + real q_noliqmn, q_noliqmx + real scsacimn, scsacimx + + real :: dtpinv + +! arrays for temporary bin space + + real :: xden,xmlt,cmlt,cmlttot,fventm,fventh,am,ah,felfinv,dmwdt + + real :: qhmlrtmp,qhmlrtmp2, chmlrtmp, chmlrtmpd1inf, chlmlrtmp, zhlmlrtmp, zhlmlrrtmp, qvs0,tmpcmlt + + real :: term1,term2,term3,term4 + real :: qaacw ! combined qsacw-qhacw for WSM6 variation + + + +! +! #################################################################### +! +! Start routine +! +! #################################################################### + + + +! + + pb(:) = 0.0 + pinit(:) = 0.0 + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + istag = 0 + jstag = 0 + kstag = 1 + + + +! +! slope intercepts +! + + IF ( ngs .lt. nz ) THEN +! write(0,*) 'Error in ICEZVD: Must have ngs .ge. nz!' +! STOP + ENDIF + + cntnic_noliq = 0 + q_noliqmn = 0.0 + q_noliqmx = 0.0 + scsacimn = 0.0 + scsacimx = 0.0 + + ldovol = .false. + + DO il = lc,lhab + ldovol = ldovol .or. ( lvol(il) .gt. 1 ) + ENDDO + + +! DO il = lc,lhab +! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) +! ENDDO + +! +! density maximums and minimums +! + +! +! Set terminal velocities... +! also set drag coefficients +! + + dtpinv = 1.d0/dtp + +! + +! +! electricity constants +! +! mixing ratio epsilon +! + qeps = 1.0e-20 + +! rebound efficiency (erbnd) +! +! +! +! constants +! + + cp608 = 0.608 + aradcw = -0.27544 + bradcw = 0.26249e+06 + cradcw = -1.8896e+10 + dradcw = 4.4626e+14 + bta1 = 0.6 + cnit = 1.0e-02 + dragh = 0.60 + dnz00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + pii = piinv ! 1./pi + pid4 = pi/4.0 +! qscrit = 6.0e-04 + gf1 = 1.0 ! gamma(1.0) + gf1p5 = 0.8862269255 ! gamma(1.5) + gf2 = 1.0 ! gamma(2.0) + gf3 = 2.0 ! gamma(3.0) + gf3p5 = 3.32335097 ! gamma(3.5) + gf4 = 6.00 ! gamma(4.0) + gf5 = 24.0 ! gamma(5.0) + gf6 = 120.0 ! gamma(6.0) + gf7 = 720.0 ! gamma(7.0) + gf4br = 17.837861981813607 ! gamma(4.0+br) + gf4ds = 10.41688578110938 ! gamma(4.0+ds) + gf4p5 = 11.63172839656745 ! gamma(4.0+0.5) + gf3ds = 3.0458730354120997 ! gamma(3.0+ds) + gf1ds = 0.8863557896089221 ! gamma(1.0+ds) + gr = 9.8 + gf43rds = 0.8929795116 ! gamma(4./3.) + gf53rds = 0.9027452930 ! gamma(5./3.) + gf73rds = 1.190639349 ! gamma(7./3.) + gf83rds = 1.504575488 ! gamma(8./3.) + + gamice73fac = (Gamma_sp(7./3. + cinu))**3/ (Gamma_sp(1. + cinu)**3 * (1. + cinu)**4) + gamsnow73fac = (Gamma_sp(7./3. + snu))**3/ (Gamma_sp(1. + snu)**3 * (1. + snu)**4) + +! gcnup1 = Gamma_sp(cnu + 1.) +! gcnup2 = Gamma_sp(cnu + 2.) +! +! constants +! +! +! general constants for microphysics +! + brz = 100.0 + arz = 0.66 + + bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/ & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)) + + galpharaut = (6.+alpharaut)*(5.+alpharaut)*(4.+alpharaut)/ & + & ((3.+alpharaut)*(2.+alpharaut)*(1.+alpharaut)) + + vfrz = 0.523599*(dfrz)**3 + vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) + vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) + + snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + + tdtol = 1.0e-05 + tfrcbw = tfr - cbw + tfrcbi = tfr - cbi +! +! +! #ifdef COMMAS +! print*,'ventr,ventc = ',ventr,ventc + +! +! Set up look up tables for supersaturation w.r.t. liq and ice +! +!VD$L SKIP +! do l = 1,nqsat +! temq = 163.15 + (l-1)*fqsat +! tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) +! tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) +! end do + + mltmass0inv = 1.0/( 1000.0* xvmx(lr) ) ! for drops melting from ice with diameter > 1.9cm + mltmass1inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize1)**3) ) ! for drops melting from ice with diameter > 1.9cm; 0.01 converts cm to m, 0.5 conv. diam to radius + mltmass2inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize2)**3) ) ! for drops melting from ice with 0.9cm < d < 1.9cm (or 1.6cm to 1.9cm) + mltmass3inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize3)**3) ) ! for drops melting from ice with 0.9cm < d < 1.6cm + mltmass1cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize1)**3) + mltmass2cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize2)**3) + mltmass3cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize3)**3) + +! real, parameter :: mltdiam1 = 9.0e-3, mltdiam2 = 19.0e-3, mltdiam05 = 4.5e-3 + + IF ( ibinnum == 1 ) THEN + numdiam = 1 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 4.5e-3 + ELSEIF ( ibinnum == 2 ) THEN + numdiam = 2 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = mltdiam1/6. ! 1.5e-3 + mltdiam(2) = mltdiam1/2. ! 4.5e-3 + ELSEIF ( ibinnum > 2 ) THEN + numdiam = Min(ibinnum, ndiam) + DO k = 1,numdiam + mltdiam(k) = (k - 0.5)*mltdiam1/float(numdiam) + ENDDO + + ELSE + numdiam = 5 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 0.5e-3 + mltdiam(2) = 1.0e-3 + mltdiam(3) = 2.0e-3 + mltdiam(4) = 4.0e-3 + mltdiam(5) = 6.0e-3 + ENDIF + + + IF ( numshedregimes == 2 ) THEN + mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3 + mltdiam(ndiam+2) = mltdiam3 ! 19.0e-3 + mltdiam(ndiam+3) = mltdiam4 !100.0e-3 + ELSEIF ( numshedregimes == 3 ) THEN + mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3 + mltdiam(ndiam+2) = mltdiam2 ! 16.0e-3 + mltdiam(ndiam+3) = mltdiam3 ! 19.0e-3 + mltdiam(ndiam+4) = mltdiam4 !200.0e-3 + ENDIF + + kzb = 1 + kze = ktile +! if (kzend .eq. nzend) kze = kzend-kzbeg+1-kstag + +! +! cw constants in mks units +! +! cwmasn = 4.25e-15 ! radius of 1.0e-6 + mwfac = 6.0**(1./3.) + IF ( ipconc .ge. 2 ) THEN +! cwmasn = xvmn(lc)*1000. +! cwradn = 1.0e-6 +! cwmasx = xvmx(lc)*1000. + ENDIF + rwmasn = xvmn(lr)*1000. + rwmasx = xvmx(lr)*1000. + +! +! ci constants in mks units +! + cimasn = Min(cimas0, cimas1) ! 12 microns for 0.1871*(xmas(mgs,li)**(0.3429)) + cimasx = 1.0e-8 ! 338 microns + ccimx = 5000.0e3 ! max of 5000 per liter + +! +! constants for paramerization +! +! +! set save counter (number of saves): nsvcnt +! +! nsvcnt = 0 + iend = 0 + + +! timetd1 = etime(tarray) +! timetd1 = tarray(1) + +! +!*********************************************************** +! start jy loop +!*********************************************************** +! + +! do 9999 jy = 1,ny-jstag +! +! VERY IMPORTANT: SET jy = jgs +! + jy = jgs + + +! t1(:,:,:) = 0 +! t2(:,:,:) = 0 +! t3(:,:,:) = 0 +! t4(:,:,:) = 0 +! t5(:,:,:) = 0 +! t6(:,:,:) = 0 +! t8(:,:,:) = 0 + + IF ( ipconc < 2 ) THEN ! Make a copy of cloud droplet mixing ratio to use for homogeneous freezing + DO kz = 1,kze + DO ix = 1,itile + t9(ix,jy,kz) = an(ix,jy,kz,lc) + ENDDO + ENDDO + ENDIF + +! +!..Gather microphysics +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE' + + + + nxmpb = 1 + nzmpb = 1 + nxz = itile*nz + numgs = nxz/ngs + 1 +! write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE: nx,nz,nxz,numgs,ngs = ',nx,nz,nxz,numgs,ngs + + do 1000 inumgs = 1,numgs + ngscnt = 0 + + do kz = nzmpb,kze + do ix = nxmpb,itile + + pqs(1) = t00(ix,jy,kz) +! pqs(kz) = t00(ix,jy,kz) + + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) + temcg(1) = temg(1) - tfr + tqvcon = temg(1)-cbw + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) + + qss(1) = qvs(1) + +! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN +! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz) +! ENDIF + + if ( temg(1) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) + qss(1) = qis(1) + else +! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN +! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz) +! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz)) +! ENDIF + end if +! + ishail = .false. + IF ( lhl > 1 ) THEN + IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) ishail = .true. + ENDIF + + if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & an(ix,jy,kz,li) .gt. qxmin(li) .or. & + & an(ix,jy,kz,lr) .gt. qxmin(lr) .or. & + & an(ix,jy,kz,ls) .gt. qxmin(ls) .or. & + & an(ix,jy,kz,lh) .gt. qxmin(lh) .or. ishail ) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if + enddo !ix + nxmpb = 1 + enddo !kz + 1100 continue + + if ( ngscnt .eq. 0 ) go to 9998 + + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5' + +! write(0,*) 'allocating qc' + + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + vtxbar(:,:,:) = 0.0 + xdia(:,:,:) = 0.0 + raindn(:,:) = 900. + cx(:,:) = 0.0 + alpha(:,:) = 0.0 + DO il = li,lhab + DO mgs = 1,ngscnt + rimdn(mgs,il) = rimedens ! xdn0(il) + ENDDO + ENDDO +! +! define temporaries for state variables to be used in calculations +! + do mgs = 1,ngscnt + kgsm(mgs) = max(kgs(mgs)-1,1) + kgsp(mgs) = min(kgs(mgs)+1,nz-1) + kgsm2(mgs) = Max(kgs(mgs)-2,1) + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs) + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = an(igs(mgs),jy,kgs(mgs),lv) + qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv) - qv0(mgs) ! qv0(mgs) is full qv, so qwvp starts as zero! + + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/rho0(mgs)) + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs)) + temgkm2(mgs) = t0(igs(mgs),jy,kgsm2(mgs)) + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + qss(mgs) = qvs(mgs) +! es(mgs) = 6.1078e2*tabqvs(ltemq) +! eis(mgs) = 6.1078e2*tabqis(ltemq) + cnostmp(mgs) = cno(ls) +! + + il5(mgs) = 0 + if ( temg(mgs) .lt. tfr ) then + il5(mgs) = 1 + end if + enddo !mgs + + IF ( ipconc < 1 .and. lwsm6 ) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF + + +! +! zero arrays that are used but not otherwise set (tm) +! + do mgs = 1,ngscnt + qhshr(mgs) = 0.0 + end do +! +! set temporaries for microphysics variables +! + DO il = lv,lhab + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + end do + + qxw(:,:) = 0.0 + qxwlg(:,:) = 0.0 + + + + scx(:,:) = 0.0 +! +! set shape parameters +! + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + alpha(:,li) = xnu(li) + alpha(:,lc) = xnu(lc) + + IF ( imusnow == 1 ) THEN + alpha(:,ls) = alphas + ELSEIF ( imusnow == 3 ) THEN + alpha(:,ls) = xnu(ls) + ENDIF + + DO il = lc,lhab + do mgs = 1,ngscnt + IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) + DO ic = lr,lhab + dab0lh(mgs,il,ic) = dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(ic,il) + ENDDO + ENDDO + end do + + +! DO mgs = 1,ngscnt + da0lh(:) = da0(lh) + da0lr(:) = da0(lr) + IF ( lzh < 1 .or. lzhl < 1 ) THEN + rzxhlh(:) = rzhl/rz + ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN + rzxhlh(:) = 1. + ENDIF + IF ( lzr > 1 ) THEN + rzxh(:) = 1. + rzxhl(:) = 1. + ELSE + rzxh(:) = rz + rzxhl(:) = rzhl + ENDIF + + IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN + rzxs(:) = rzs + ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN + rzxs(:) = 1. + ENDIF + ! ENDDO + + IF ( lhl .gt. 1 ) THEN + DO mgs = 1,ngscnt + da0lhl(mgs) = da0(lhl) + ENDDO + ENDIF + + ventrx(:) = ventr + ventrxn(:) = ventrn + gf1palp(:) = gamma_sp(1.0 + alphar) + +! +! set concentrations +! +! ssmax = 0.0 + + + + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + IF ( lcina .gt. 1 ) THEN + cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) + ELSE + cina(mgs) = cx(mgs,li) + ENDIF + IF ( lcin > 1 ) THEN + ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin) + ENDIF + end do + end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + IF ( lss > 1 ) THEN + ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) + ENDIF + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = 0.0 + ENDIF + IF ( lccna .gt. 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) + ELSE + ccna(mgs) = cx(mgs,lc) + ENDIF + end do +! ELSE +! cx(mgs,lc) = Abs(ccn) + end if + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! cx(mgs,lr) = 0.0 + ELSEIF ( cx(mgs,lr) .eq. 0.0 .and. qx(mgs,lr) .lt. 3.0*qxmin(lr) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lr) + qx(mgs,lr) = 0.0 + ELSE + cx(mgs,lr) = Max( 1.e-9, cx(mgs,lr) ) + ENDIF + end do + end if + if ( ipconc .ge. 4 ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) + IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! cx(mgs,ls) = 0.0 + ELSEIF ( cx(mgs,ls) .eq. 0.0 .and. qx(mgs,ls) .lt. 3.0*qxmin(ls) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,ls) + qx(mgs,ls) = 0.0 + ELSE + cx(mgs,ls) = Max( 1.e-9, cx(mgs,ls) ) + + IF ( ilimit .ge. ipc(ls) ) THEN + tmp = (xdn0(ls)*cx(mgs,ls))/(rho0(mgs)*qx(mgs,ls)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,ls)*(tmp2) + IF ( cnox .gt. 3.0*cno(ls) ) THEN + cx(mgs,ls) = 3.0*cno(ls)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 5 ) then + do mgs = 1,ngscnt + + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) + IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! cx(mgs,lh) = 0.0 + ELSEIF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) + qx(mgs,lh) = 0.0 + ELSE + cx(mgs,lh) = Max( 1.e-9, cx(mgs,lh) ) + IF ( ilimit .ge. ipc(lh) ) THEN + tmp = (xdn0(lh)*cx(mgs,lh))/(rho0(mgs)*qx(mgs,lh)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lh)*(tmp2) + IF ( cnox .gt. 3.0*cno(lh) ) THEN + cx(mgs,lh) = 3.0*cno(lh)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if + + if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then + do mgs = 1,ngscnt + + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) + IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN + cx(mgs,lhl) = 0.0 + ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) + qx(mgs,lhl) = 0.0 + ELSE + cx(mgs,lhl) = Max( 1.e-9, cx(mgs,lhl) ) + IF ( ilimit .ge. ipc(lhl) ) THEN + tmp = (xdn0(lhl)*cx(mgs,lhl))/(rho0(mgs)*qx(mgs,lhl)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lhl)*(tmp2) + IF ( cnox .gt. 3.0*cno(lhl) ) THEN + cx(mgs,lhl) = 3.0*cno(lhl)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if + +! +! Set mean particle volume +! + IF ( ldovol ) THEN + + vx(:,:) = 0.0 + + DO il = li,lhab + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + ENDDO + + ENDIF + + ENDDO + + ENDIF + + + + + +! +! set factors +! + do mgs = 1,ngscnt +! + ssi(mgs) = qx(mgs,lv)/qis(mgs) + ssw(mgs) = qx(mgs,lv)/qvs(mgs) +! + tsqr(mgs) = temg(mgs)**2 +! + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) +! + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 + +! felf = latent heat of fusion, fels = LH of sublimation, felv = LH of vaporization + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 +! + fels(mgs) = felv(mgs) + felf(mgs) +! + felvs(mgs) = felv(mgs)*felv(mgs) + felss(mgs) = fels(mgs)*fels(mgs) + + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + felscp(mgs) = fels(mgs)*cpi + felfcp(mgs) = felf(mgs)*cpi + ELSE + + ! equations from appendix in Bryan and Morrison (2012, MWR) + ! note that rw is Rv in the paper, and rd is R. + + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + + IF ( eqtset == 2 ) THEN ! compact form from treating dT/dt = theta*d(pi)/dt + pi*d(theta)dt and then applied to theta assuming constant pi + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm + felfcp(mgs) = felf(mgs)/cvm + + ELSE + ! equivalent version that applies separate updates of latent heating to theta and pi, when both are returned. + + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felscp(mgs) = (fels(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felfcp(mgs) = felf(mgs)*cv/(cp*cvm) + + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felspi(mgs) = pi0(mgs)*rovcp*(fels(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felfpi(mgs) = pi0(mgs)*rovcp*(felf(mgs)/(cvm*temg(mgs))) + + ENDIF + + ENDIF +! + fgamw(mgs) = felvcp(mgs)/pi0(mgs) + fgams(mgs) = felscp(mgs)/pi0(mgs) +! + fcqv1(mgs) = 4098.0258*pi0(mgs)*fgamw(mgs) + fcqv2(mgs) = 5807.6953*pi0(mgs)*fgams(mgs) + fcc3(mgs) = felfcp(mgs)/pi0(mgs) +! +! fwvdf = water vapor diffusivity + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)*(101325.0/(pres(mgs))) +! +! fadvisc = 'd' for dynamic viscosity +! fakvisc = 'k' for kinematic viscosity + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))*(temg(mgs)/296.0)**(1.5) ! dynamic visc. +! + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) ! divide by rho_air to get kinematic visc. (note the 'k' vs. 'd') +! + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fci(mgs) = (2.118636 + 0.007371*(temcgx(mgs)))*(1.0e+03) +! + if ( temg(mgs) .lt. 273.15 ) then + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4203.1548 + (1.30572e-2)*((temcgx(mgs)-35.)**2) & + & + (1.60056e-5)*((temcgx(mgs)-35.)**4) + end if + if ( temg(mgs) .ge. 273.15 ) then + temcgx(mgs) = min(temg(mgs),308.15) + temcgx(mgs) = max(temcgx(mgs),273.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4243.1688 + (3.47104e-1)*(temcgx(mgs)**2) + end if +! + ftka(mgs) = tka0*fadvisc(mgs)/advisc1 ! thermal conductivity: proportional to dynamic viscosity + fthdf(mgs) = ftka(mgs)*cpi*rhoinv(mgs) +! + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) ! Schmidt number + fpndl(mgs) = (fakvisc(mgs)/fthdf(mgs)) ! Prandl number (only used for bin melting) +! + fai(mgs) = (fels(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbi(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qis(mgs))) + fav(mgs) = (felv(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbv(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qvs(mgs))) + + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + +! + end do +! +! +! ice habit fractions +! +! +! +! Set density +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set density' +! + + do mgs = 1,ngscnt + xdn(mgs,li) = xdn0(li) + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + xdn(mgs,ls) = xdn0(ls) + xdn(mgs,lh) = xdn0(lh) + IF ( lvol(ls) .gt. 1 ) THEN + IF ( vx(mgs,ls) .gt. 0.0 .and. qx(mgs,ls) .gt. qxmin(ls) ) THEN + xdn(mgs,ls) = Min( xdnmx(ls), Max( xdnmn(ls), rho0(mgs)*qx(mgs,ls)/vx(mgs,ls) ) ) + ENDIF + ENDIF + + IF ( lvol(lh) .gt. 1 ) THEN + IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( mixedphase ) THEN + ELSE + dnmx = xdnmx(lh) + ENDIF + xdn(mgs,lh) = Min( dnmx, Max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) ) + vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) + + ELSEIF ( vx(mgs,lh) == 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN ! if volume is zero, need to initialize the default value + + vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) + + ENDIF + ENDIF + + IF ( lhl .gt. 1 ) THEN + + xdn(mgs,lhl) = xdn0(lhl) + + IF ( lvol(lhl) .gt. 1 ) THEN + IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + + IF ( mixedphase .and. lhlw > 1 ) THEN + ELSE + dnmx = xdnmx(lhl) + ENDIF + + xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + + ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value + + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + + ENDIF + ENDIF + + ENDIF + + + end do + + + IF ( imurain == 3 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 0.0 + alphamlr = -2.0/3.0 + ELSE + alphashr = xnu(lr) + alphamlr = xnu(lr) + ENDIF +! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor +! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) + massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor + massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) + ELSEIF ( imurain == 1 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 4.0 + alphamlr = 4.0 + ELSE + alphashr = alphar + alphamlr = alphar + ENDIF +! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor +! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) + massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor + massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) + ENDIF + + +! +! set some values for ice nucleation +! + do mgs = 1,ngscnt + kp1 = Min(nz, kgs(mgs)+1 ) +! wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & +! & +w(igs(mgs),jgs,kgs(mgs))) + + + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,kgsm(mgs))) + cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) + end do + +! +! Set a couple of cloud variables... +! + +! SUBROUTINE setvt(ngscnt,qx,qxmin,cx,rho0,rhovt,xdia,cno, +! : xmas,xdn,xvmn,xvmx,xv,cdx, +! : ipconc,ndebug) +! SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno, & +! & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & +! & ipconc1,ndebug1,ngs,nz,kgs,cwnccn,fadvisc, & +! & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & +! & itype1a,itype2a,temcg,infdo,alpha) + + + infdo = 0 + IF ( rimdenvwgt > 0 ) infdo = 1 + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebug,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) + + + IF ( lwsm6 .and. ipconc == 0 ) THEN + tmp = Max(qxmin(lh), qxmin(ls)) + DO mgs = 1,ngscnt + sum = qx(mgs,lh) + qx(mgs,ls) + IF ( sum > tmp ) THEN + vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum + ELSE + vt2ave(mgs) = 0.0 + ENDIF + ENDDO + ENDIF + + +! +! Set number concentrations (need xdia from setvt) +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration' + IF ( ipconc .lt. 1 ) THEN + cina(1:ngscnt) = cx(1:ngscnt,li) + ENDIF + if ( ipconc .lt. 5 ) then + do mgs = 1,ngscnt + + + IF ( ipconc .lt. 3 ) THEN +! cx(mgs,lr) = 0.0 + if ( qx(mgs,lr) .gt. qxmin(lh) ) then +! cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) +! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + end if + ENDIF + + IF ( ipconc .lt. 4 ) THEN +! tmp = cx(mgs,ls) +! cx(mgs,ls) = 0.0 + if ( qx(mgs,ls) .gt. qxmin(ls) ) then +! cx(mgs,ls) = cno(ls)*xdia(mgs,ls,1) +! xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + end if + ENDIF ! ( ipconc .lt. 4 ) + + IF ( ipconc .lt. 5 ) THEN + + +! cx(mgs,lh) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then +! cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) +! xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) +! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + + ENDIF ! ( ipconc .lt. 5 ) + + end do + end if + + IF ( ipconc .ge. 2 ) THEN + DO mgs = 1,ngscnt + + rb(mgs) = 0.5*xdia(mgs,lc,1)*((1./(1.+alpha(mgs,lc))))**(1./6.) + xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & + & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) + IF ( rb(mgs) .gt. 3.51e-6 ) THEN +! rh(mgs) = Max( 0.5d0*xdia(mgs,lc,1), 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + rh(mgs) = Max( 41.d-6, 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + ELSE + rh(mgs) = 41.d-6 + ENDIF + IF ( xl2p(mgs) .gt. 0.0 ) THEN + nh(mgs) = 4.2d9*xl2p(mgs) + ELSE + nh(mgs) = 1.e30 + ENDIF + ENDDO + ENDIF + +! +! +! +! +! maximum depletion tendency by any one source +! +! + if( ndebug .ge. 0 ) THEN +!mpi! write(0,*) 'Set depletion max/min1' + endif + do mgs = 1,ngscnt + qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))*dtpinv ! depletion by all vap. dep to ice. + + IF ( qx(mgs,lc) < qxmin(lc) ) qvimxd(mgs) = 0.99*(qx(mgs,lv)-qis(mgs))*dtpinv ! this makes virtually no difference whatsoever, but what the heck + + qvimxd(mgs) = max(qvimxd(mgs), 0.0) + + frac = 0.1d0 + qimxd(mgs) = frac*qx(mgs,li)*dtpinv + qcmxd(mgs) = frac*qx(mgs,lc)*dtpinv + qrmxd(mgs) = frac*qx(mgs,lr)*dtpinv + qsmxd(mgs) = frac*qx(mgs,ls)*dtpinv + qhmxd(mgs) = frac*qx(mgs,lh)*dtpinv + IF ( lhl > 1 ) qhlmxd(mgs) = frac*qx(mgs,lhl)*dtpinv + end do +! + if( ndebug .ge. 0 ) THEN +!mpi! write(0,*) 'Set depletion max/min2' + endif + + do mgs = 1,ngscnt +! + if ( qx(mgs,lc) .le. qxmin(lc) ) then + ccmxd(mgs) = 0.20*cx(mgs,lc)*dtpinv + else + IF ( ipconc .ge. 2 ) THEN + ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv + ELSE + ccmxd(mgs) = frac*qx(mgs,lc)/(xmas(mgs,lc)*rho0(mgs)*dtp) + ENDIF + end if +! + if ( qx(mgs,li) .le. qxmin(li) ) then + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + else + IF ( ipconc .ge. 1 ) THEN + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + ELSE + cimxd(mgs) = frac*qx(mgs,li)/(xmas(mgs,li)*rho0(mgs)*dtp) + ENDIF + end if +! +! + crmxd(mgs) = 0.10*cx(mgs,lr)*dtpinv + csmxd(mgs) = frac*cx(mgs,ls)*dtpinv + chmxd(mgs) = frac*cx(mgs,lh)*dtpinv + + ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + crmxd(mgs) = frac*cx(mgs,lr)*dtpinv + csmxd(mgs) = frac*cx(mgs,ls)*dtpinv + chmxd(mgs) = frac*cx(mgs,lh)*dtpinv + + qxmxd(mgs,lv) = Max(0.0, 0.1*(qx(mgs,lv) - qvs(mgs))*dtpinv) + + DO il = lc,lhab + qxmxd(mgs,il) = frac*qx(mgs,il)*dtpinv + cxmxd(mgs,il) = frac*cx(mgs,il)*dtpinv + ENDDO + + end do + + + + + + + + + ! default factors between mean volume and maximum mass volume + maxmassfac(lc) = ( (2. + 3.*(1. + xnu(lc)) )**3/( 3.*(1. + xnu(lc)) ) ) + maxmassfac(li) = ( (2. + 3.*(1. + xnu(li)) )**3/( 3.*(1. + xnu(li)) ) ) + + IF ( imurain == 3 ) THEN + maxmassfac(lr) = ( (2. + 3.*(1. + xnu(lr)) )**3/( 3.*(1. + xnu(lr)) ) ) + ELSE + maxmassfac(lr) = (3.0 + alphar)**3/ & + & ((3.+alphar)*(2.+alphar)*(1. + alphar) ) + ENDIF + + IF ( imusnow == 3 ) THEN + maxmassfac(ls) = ( (2. + 3.*(1. + alphas) )**3/( 3.*(1. + alphas) ) ) + ELSE + maxmassfac(ls) = (3.0 + alphas)**3/ & + & ((3.+alphas)*(2.+alphas)*(1. + alphas) ) + ENDIF + + maxmassfac(lh) = (3.0 + alphah)**3/ & + & ((3.+alphah)*(2.+alphah)*(1. + alphah) ) + + IF ( lhl > 1 ) THEN + maxmassfac(lhl) = (3.0 + alphahl)**3/ & + & ((3.+alphahl)*(2.+alphahl)*(1. + alphahl) ) + ENDIF + + + + DO mgs = 1,ngscnt + DO il = lh,lhab ! graupel and hail only + + vshdgs(mgs,il) = vshd ! base value + + IF ( qx(mgs,il) > qxmin(il) ) THEN + + ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter. + tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + + IF ( tmpdiam > sheddiam0 ) THEN + vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice + ELSEIF ( tmpdiam > sheddiam ) THEN ! intermediate size + vshdgs(mgs,il) = 0.523599*(3.0e-3)**3/massfacshr ! 3.0mm drops from medium-large ice + ELSE +! vshdgs(mgs,il) = Min( xvmx(lr), xv(mgs,il)*xdn(mgs,il)*0.001 ) ! size of drop from melted mean ice particle + vshdgs(mgs,il) = Min( xvmx(lr), 6./pi*xdn(mgs,il)*0.001*tmpdiam**3 )/massfacshr ! size of drop from melted mean ice particle; 0.001 is 1/rhow + ENDIF + ENDIF + ENDDO + ENDDO + +! +! +! microphysics source terms (1/s) for mixing ratios +! +! +! +! Collection efficiencies: +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies' +! + do mgs = 1,ngscnt +! +! +! + qcwresv(mgs) = 0.0 + ccwresv(mgs) = 0.0 + + erw(mgs) = 0.0 + esw(mgs) = 0.0 + ehw(mgs) = 0.0 + ehlw(mgs) = 0.0 +! ehxw(mgs) = 0.0 +! + err(mgs) = 0.0 + esr(mgs) = 0.0 + il2(mgs) = 0 + il3(mgs) = 0 + ehr(mgs) = 0.0 + ehlr(mgs) = 0.0 +! ehxr(mgs) = 0.0 +! + eri(mgs) = 0.0 + esi(mgs) = 0.0 + ehi(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn + ehis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn + ehli(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn + ehlis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn +! ehxi(mgs) = 0.0 +! + ers(mgs) = 0.0 + ess(mgs) = 0.0 + ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn + ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn + ehscnv(mgs) = 0.0 +! ehxs(mgs) = 0.0 +! + eiw(mgs) = 0.0 + eii(mgs) = 0.0 + + ehsclsn(mgs) = 0.0 + ehiclsn(mgs) = 0.0 + ehlsclsn(mgs) = 0.0 + ehliclsn(mgs) = 0.0 + esiclsn(mgs) = 0.0 + + +! reserve droplets + IF ( exwmindiam > 0 .and. qx(mgs,lc) > qxmin(lc) ) THEN + tmp = cx(mgs,lc)*Exp(- (exwmindiam/xdia(mgs,lc,1))**3 ) + ccwresv(mgs) = Min( cx(mgs,lc), Max( 2.e6, cx(mgs,lc) - tmp ) ) + + tmp = cx(mgs,lc) - ccwresv(mgs) + + volt = pi/6.*(exwmindiam)**3 + qcwresv(mgs) = qx(mgs,lc) - tmp*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + + + IF ( .false. .and. qx(mgs,lc) > 0.1e-3 ) THEN + + write(0,*) 'cx,qx,crsv,qrsv = ',cx(mgs,lc),qx(mgs,lc),ccwresv(mgs),qcwresv(mgs) + + ENDIF + + ENDIF + + + icwr(mgs) = 1 + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + DO il = 1,8 + IF ( cwrad .ge. 1.e-6*cwr(il,1) ) icwr(mgs) = il + ENDDO + ENDIF + + + irwr(mgs) = 1 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) irwr(mgs) = il + ENDDO + ENDIF + + + igwr(mgs) = 1 +! IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN +! rwrad = 0.5*xdia(mgs,lr,1) +! setting erw = 1 always, so now use igwr for graupel + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) igwr(mgs) = il + ENDDO + ENDIF + + IF ( lhl .gt. 1 ) THEN ! hail is turned on + ihlr(mgs) = 1 + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) ihlr(mgs) = il + ENDDO + ENDIF + ENDIF + +! +! +! Ice-Ice: Collection (cxc) efficiencies +! +! + if ( qx(mgs,li) .gt. qxmin(li) ) then +! IF ( ipconc .ge. 14 ) THEN +! eii(mgs)=0.1*exp(0.1*temcg(mgs)) +! if ( temg(mgs) .lt. 243.15 .and. qx(mgs,lc) .gt. 1.e-6 ) then +! eii(mgs)=0.1 +! end if +! +! ELSE + eii(mgs) = exp(0.025*Min(temcg(mgs),0.0)) ! alpha1 from LFO83 (21) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) eii(mgs) = 1.0 + end if +! +! +! +! Ice-cloud water: Collection (cxc) efficiencies +! +! + eiw(mgs) = 0.0 + if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then + + + if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then +! erm 5/10/2007 test following change: +! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then + eiw(mgs) = 0.5 + end if + if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 + end if + +! +! +! +! Rain: Collection (cxc) efficiencies +! +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lc).gt.qxmin(lc) ) then + + IF ( lnr .gt. 1 ) THEN + erw(mgs) = 1.0 + + ELSE + +! cwrad = 0.5*xdia(mgs,lc,1) +! erw(mgs) = +! > min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! IF ( xdia(mgs,lc,1) .lt. 2.4e-06 .or. xdia(mgs,lr,1) .le. 50.0e-6 ) THEN +! erw(mgs)=0.0 +! ENDIF +! erw(mgs) = ew(icwr(mgs),igwr(mgs)) +! interpolate along droplet radius + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = irwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,3) + rwrad = 0.5*xdia(mgs,lr,3) + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + erw(mgs) = Max(0.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) )) + +! write(iunit,*) 'erw: ',erw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + + erw(mgs) = Max(0.0, erw(mgs) ) + IF ( rwrad .lt. 50.e-6 ) THEN + erw(mgs) = 0.0 + ELSEIF ( rwrad .lt. 100.e-6 ) THEN ! linear change from zero at 50 to erw at 100 microns + erw(mgs) = erw(mgs)*(rwrad - 50.e-6)/50.e-6 + ENDIF + + ENDIF + end if + IF ( cx(mgs,lc) .le. 0.0 ) erw(mgs) = 0.0 +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr).gt.qxmin(lr) ) then + err(mgs)=1.0 + end if +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,ls).gt.qxmin(ls) ) then + ers(mgs)=1.0 + end if +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,li).gt.qxmin(li) ) then +! IF ( vtxbar(mgs,lr,1) .gt. vtxbar(mgs,li,1) .and. +! : xdia(mgs,lr,3) .gt. 200.e-6 .and. xdia(mgs,li,3) .gt. 100.e-6 ) THEN + eri(mgs) = eri0 +! cwrad = 0.5*xdia(mgs,li,3) +! eri(mgs) = +! > 1.0*min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! ENDIF +! if ( xdia(mgs,li,1) .lt. 10.e-6 ) eri(mgs)=0.0 + if ( xdia(mgs,li,3) .lt. eri_cimin ) eri(mgs)=0.0 + end if +! +! +! Snow aggregates: Collection (cxc) efficiencies +! +! Modified by ERM with a linear function for small droplets and large +! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997 (Fig. 14-13), which +! allows collection of very small droplets, albeit at low efficiency. But slow +! fall speeds of snow make up for the efficiency. +! + esw(mgs) = 0.0 + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lc).gt.qxmin(lc) ) then + esw(mgs) = 0.5 + if ( xdia(mgs,lc,1) .gt. 15.e-6 .and. xdia(mgs,ls,1) .gt. 100.e-6) then + esw(mgs) = 0.5 + ELSEIF ( xdia(mgs,ls,1) .ge. 500.e-6 ) THEN + esw(mgs) = Min(0.5, 0.05 + (0.8-0.05)/(40.e-6)*xdia(mgs,lc,1) ) + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lr).gt.qxmin(lr) & + & .and. temg(mgs) .lt. tfr - 1. & + & ) then + esr(mgs)=Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,ls,1)) + IF ( qx(mgs,ls) < 1.e-4 .and. qx(mgs,lr) < 1.e-4 ) il2(mgs) = 1 + end if + + IF ( ipconc < 3 .and. temg(mgs) < tfr .and. qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr) < 1.e-4 ) THEN + il3(mgs) = 1 + ENDIF +! +! if ( qx(mgs,ls).gt.qxmin(ls) ) then + if ( temcg(mgs) < 0.0 ) then + + IF ( ipconc .lt. 4 .or. temcg(mgs) < esstem1 ) THEN + ess(mgs) = 0.0 +! ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) +! ess(mgs)=min(0.1,ess(mgs)) + + ELSE + + fac = Abs(ess0) + IF ( .true. .and. ess0 < 0.0 ) THEN +! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN + IF ( wvel(mgs) > 2.0 ) THEN + ! assume convective cell or downdraft + fac = 0.0 + ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values + fac = Max(0.0, 2.0 - wvel(mgs))*fac + ENDIF + ENDIF + + IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25 + ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2 + ELSEIF ( temcg(mgs) >= esstem2 ) THEN + ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) ) + ENDIF + + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,li).gt.qxmin(li) ) then + esiclsn(mgs) = esi_collsn +! IF ( ipconc .lt. 4 ) THEN + IF ( ipconc < 1 .and. lwsm6 ) THEN + esi(mgs) = exp(0.7*min(temcg(mgs),0.0)) + ELSE + esi(mgs) = esi0*exp(0.1*min(temcg(mgs),0.0)) + esi(mgs) = Min(0.1,esi(mgs)) + ENDIF + IF ( ipconc .le. 3 ) THEN + esi(mgs) = exp(0.025*min(temcg(mgs),0.0)) ! LFO +! esi(mgs) = Min(0.5, exp(0.025*min(temcg(mgs),0.0)) ) ! LFO +! esi(mgs)=0.5*exp(0.1*min(temcg(mgs),0.0)) ! 10ice + ENDIF +! ELSE ! zrnic/ziegler 1993 +! esi(mgs)= 0.1 ! 0.5*exp(0.1*min(temcg(mgs),0.0)) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0 + end if +! +! +! +! +! Graupel: Collection (cxc) efficiencies +! +! + xmascw(mgs) = xmas(mgs,lc) + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc).gt.qxmin(lc) ) then !{ + ehw(mgs) = 1.0 + IF ( iehw .eq. 0 ) THEN + ehw(mgs) = ehw0 ! default value is 1.0 + ELSEIF ( iehw .eq. 1 .or. iehw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehw(mgs) = Min( ehw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) + + ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = igwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) ) + ehw(mgs) = Min( ehw(mgs), tmp ) + +! write(iunit,*) 'ehw: ',ehw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehw(mgs) = ehw(mgs) + (1.0 - ehw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + + ELSEIF ( iehw .eq. 3 .or. iehw .eq. 10 ) THEN ! use fraction of droplets greater than dmincw diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + xmascw(mgs) = xmas(mgs,lc) + xdn0(lc)*(pi*dmincw**3/6.0) ! this is the average mass of the droplets with d > dmincw + ehw(mgs) = Min( ehw(mgs), tmp ) + ELSEIF ( iehw .eq. 4 .or. iehw .eq. 10 ) THEN ! Cober and List 1993, eq. 19-20 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lh,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lh,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehw(mgs) = Min( ehw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0 + + ehw(mgs) = Min( ehw0, ehw(mgs) ) + + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehw(mgs) = 0.0 + ENDIF + + end if !} +! + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then +! ehr(mgs) = Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,lh,1)) +! ehr(mgs) = 1.0 + ehr(mgs) = Exp(-(40.e-6)/xdia(mgs,lr,3))*Exp(-40.e-6/xdia(mgs,lh,3)) + ehr(mgs) = Min( ehr0, ehr(mgs) ) + end if +! + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! for 2-moment, used as default for ehs and ehls. Otherwise not used for snow->graupel conversion + ELSE + ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) + ENDIF + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then + ehsclsn(mgs) = ehs_collsn + IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN + ehsclsn(mgs) = 0.0 + ELSEIF ( xdia(mgs,ls,3) < 150.e-6 ) THEN + ehsclsn(mgs) = ehs_collsn*(xdia(mgs,ls,3) - 40.e-6)/(150.e-6 - 40.e-6) + ELSE + ehsclsn(mgs) = ehs_collsn + ENDIF +! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density + ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density + ehs(mgs) = Min(ehs(mgs),ehsmax) + IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0 + end if + ENDIF +! + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,li).gt.qxmin(li) ) then + ehiclsn(mgs) = ehi_collsn + ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 + end if + + IF ( lis > 1 ) THEN + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lis).gt.qxmin(lis) ) then + ehisclsn(mgs) = ehi_collsn + ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 + end if + ENDIF + + +! +! +! Hail: Collection (cxc) efficiencies +! +! + IF ( lhl .gt. 1 ) THEN + + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lc).gt.qxmin(lc) ) then + IF ( iehw == 3 ) iehlw = 3 + IF ( iehw == 4 ) iehlw = 4 + ehlw(mgs) = ehlw0 + IF ( iehlw .eq. 0 ) THEN + ehlw(mgs) = ehlw0 ! default value is 1.0 + ELSEIF ( iehlw .eq. 1 .or. iehlw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehlw(mgs) = Min( ehlw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) + + ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = ihlr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + + x1 = ew(ic, ir) + slope1*(cwrad - cwr(ic,1)) + x2 = ew(icp1,ir) + slope2*(cwrad - cwr(ic,1)) + + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) ) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehlw(mgs) = ehlw(mgs) + (1.0 - ehlw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + + ELSEIF ( iehlw .eq. 3 .or. iehlw .eq. 10 ) THEN ! use fraction of droplets greater than 15 micron diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ELSEIF ( iehlw .eq. 4 .or. iehlw .eq. 10 ) THEN ! Cober and List 1993 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lhl,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lhl,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehlw(mgs) = Min( ehlw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0 + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) + + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehlw(mgs) = 0.0 + ENDIF + + end if +! + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then + ehlr(mgs) = 1.0 + ehlr(mgs) = Min( ehlr0, ehlr(mgs) ) + end if +! + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + if ( qx(mgs,lhl).gt.qxmin(lhl) ) then + ehlsclsn(mgs) = ehls_collsn + ehls(mgs) = ehscnv(mgs) + ehls(mgs) = Min(ehls(mgs),ehsmax) + end if + ENDIF +! + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,li).gt.qxmin(li) ) then + ehliclsn(mgs) = ehli_collsn + ehli(mgs)=eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) + ehli(mgs) = Min( ehimax, Max( ehli(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehli(mgs) = 0.0 + end if + + IF ( lis > 1 ) THEN + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lis).gt.qxmin(lis) ) then + ehlisclsn(mgs) = ehli_collsn + ehlis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehlis(mgs) = Min( ehimax, Max( ehlis(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehlis(mgs) = 0.0 + end if + ENDIF + + + ENDIF ! lhl .gt. 1 + + ENDDO ! mgs loop for collection efficiencies + +! +! +! +! Set flags for plates vs. columns +! +! + do mgs = 1,ngscnt +! + xplate(mgs) = 0.0 + xcolmn(mgs) = 1.0 +! +! if ( temcg(mgs) .lt. 0. .and. temcg(mgs) .ge. -4. ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -4. .and. temcg(mgs) .ge. -9. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +!c +! if ( temcg(mgs) .lt. -9. .and. temcg(mgs) .ge. -22.5 ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -22.5 .and. temcg(mgs) .ge. -90. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +! + end do +! +! +! +! Collection growth equations.... +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: rain collects xxxxx' +! + do mgs = 1,ngscnt + qracw(mgs) = 0.0 + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. erw(mgs) .gt. 0.0 ) THEN + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 .and. qx(mgs,lr) .gt. 1.e-7 ) THEN + vt = (ar*(xdia(mgs,lc,1)**br))*rhovt(mgs) + qracw(mgs) = & + & (0.25)*pi*erw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lr) & +! > *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *Max(0.0, vtxbar(mgs,lr,1)-vt) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) +! qracw(mgs) = 0.0 +! write(iunit,*) 'qracw,cx =',qracw(mgs),1.e6*xdia(mgs,lr,1),erw(mgs) +! write(iunit,*) 'qracw,cx =',qracw(mgs),cx(mgs,lc),kgs(mgs),cx(mgs,lr),1.e6*xdia(mgs,lr,1),vtxbar(mgs,lr,1),vt +! write(iunit,*) 'vtr: ',vtxbar(mgs,lr,1), ar*gf4br/6.0*xdia(mgs,lr,1)**br, rhovt(mgs), +! : ar*gf4br/6.0*xdia(mgs,lr,1)**br * rhovt(mgs) + ENDIF + ELSE + + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( rwrad .gt. rh(mgs) ) THEN ! .or. cx(mgs,lr) .gt. nh(mgs) ) THEN + IF ( rwrad .gt. rwradmn ) THEN +! DM1CCC=A2*XNC*XNR*XVC*(((CNU+2.)/(CNU+1.))*XVC+XVR) ! (A12) +! NOTE: Result is independent of imurain, assumes mucloud = 3 + qracw(mgs) = erw(mgs)*aa2*cx(mgs,lr)*cx(mgs,lc)*xmas(mgs,lc)* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,lr))/rho0(mgs) !*rhoinv(mgs) + ELSE + + IF ( imurain == 3 ) THEN + +! DM1CCC=A1*XNC*XNR*(((CNU+3.)*(CNU+2.)/(CNU+1.)**2)*XVC**3+ ! (A14) +! 1 ((RNU+2.)/(RNU+1.))*XVC*XVR**2) + +! qracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)* & +! & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**3/(cnu + 1.)**2 + & +! & (alpha(mgs,lr) + 2.)*xv(mgs,lc)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))/rho0(mgs) !*rhoinv(mgs) +! save multiplies by converting cx*xdn*xv/rho0 to qx + qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & + & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + + ELSE ! imurain == 1 + + qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & + & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) + + ENDIF + + ENDIF + ENDIF + ENDIF + ENDIF +! qracw(mgs) = Min(qracw(mgs), qx(mgs,lc)) + qracw(mgs) = Min(qracw(mgs), qcmxd(mgs)) + ENDIF + end do +! + do mgs = 1,ngscnt + qraci(mgs) = 0.0 + craci(mgs) = 0.0 + IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN + IF ( ipconc .ge. 3 ) THEN + + tmp = eri(mgs)*aa2*cx(mgs,lr)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,lr)) + + qraci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) ) + craci(mgs) = Min( cxmxd(mgs,li), tmp ) + +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) +! +! qraci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*qx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab1(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da1(li)*xdia(mgs,li,3)**2 ) +! +! +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) +! +! craci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*cx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab0(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da0(li)*xdia(mgs,li,3)**2 ) +! +! qraci(mgs) = Min( qraci(mgs), qxmxd(mgs,li) ) +! craci(mgs) = Min( craci(mgs), cxmxd(mgs,li) ) + + ELSE + qraci(mgs) = & + & min( & + & (0.25)*pi*eri(mgs)*qx(mgs,li)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qraci(mgs) = 0.0 + end if + ENDIF + end do +! + do mgs = 1,ngscnt + qracs(mgs) = 0.0 + IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + qracs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ers(mgs)*qx(mgs,ls)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lr,1) & + & + gf4*gf3*xdia(mgs,lr,2) ) & + & , qsmxd(mgs)) + ENDIF + end do + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: snow collects xxxxx' +! + do mgs = 1,ngscnt + qsacw(mgs) = 0.0 + csacw(mgs) = 0.0 + vsacw(mgs) = 0.0 + IF ( esw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .ge. 4 ) THEN +! QSACC=CECS*RVT*A2*XNC*XNS*XVC*ROS* +! * (((CNU+2.)/(CNU+1.))*XVC+XVS)/RO + +! tmp = esw(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* +! : ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls)) + tmp = 1.0*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls)) + + qsacw(mgs) = Min( qxmxd(mgs,lc), tmp*xmas(mgs,lc)*rhoinv(mgs) ) + csacw(mgs) = Min( cxmxd(mgs,lc), tmp ) + + IF ( lvol(ls) .gt. 1 ) THEN + IF ( temg(mgs) .lt. 273.15) THEN + rimdn(mgs,ls) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,ls) = Min( Max( rimc3, rimdn(mgs,ls) ), rimc4 ) + ELSE + rimdn(mgs,ls) = 1000. + ENDIF + + vsacw(mgs) = rho0(mgs)*qsacw(mgs)/rimdn(mgs,ls) + + ENDIF + + +! qsacw(mgs) = cecs*aa2*cx(mgs,ls)*cx(mgs,lc)*xmas(mgs,lc)* +! : ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls))*rhoinv(mgs) + ELSE +! qsacw(mgs) = +! > min( +! > ((0.25)*pi)*esw(mgs)*qx(mgs,lc)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,lc,1) +! > + gf1*xdia(mgs,lc,2) ) +! < , qcmxd(mgs)) + + vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) + + qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt* & + & ( da0(ls)*xdia(mgs,ls,3)**2 + & + & dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) + qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) ) + csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc) + ENDIF + ENDIF + end do +! +! + do mgs = 1,ngscnt + qsaci(mgs) = 0.0 + csaci(mgs) = 0.0 + csaci0(mgs) = 0.0 + IF ( ipconc .ge. 4 ) THEN + IF ( esi(mgs) .gt. 0.0 .or. ( ipelec > 0 .and. esiclsn(mgs) > 0.0 )) THEN +! QSCOI=CEXS*RVT*A2*XNCI*XNS*XVCI*ROS* +! * (((CINU+2.)/(CINU+1.))*VCIP+XVS)/RO + + tmp = esiclsn(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,ls)) + + qsaci(mgs) = Min( qxmxd(mgs,li), esi(mgs)*tmp*xmas(mgs,li)*rhoinv(mgs) ) + csaci0(mgs) = tmp + csaci(mgs) = Min(cxmxd(mgs,li), esi(mgs)*tmp ) + +! qsaci(mgs) = +! > min( +! > ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) +! > + gf1*xdia(mgs,li,2) ) +! < , qimxd(mgs)) + ENDIF + ELSE ! + IF ( esi(mgs) .gt. 0.0 ) THEN + qsaci(mgs) = & + & min( & + & ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) & + & *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,ls,2) & + & + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do +! +! +! + do mgs = 1,ngscnt + qsacr(mgs) = 0.0 + qsacrs(mgs) = 0.0 + csacr(mgs) = 0.0 + IF ( esr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN +! vt = Sqrt((vtxbar(mgs,ls,1)-vtxbar(mgs,lr,1))**2 + +! : 0.04*vtxbar(mgs,ls,1)*vtxbar(mgs,lr,1) ) +! qsacr(mgs) = esr(mgs)*cx(mgs,ls)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,ls,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,ls,2)) +! qsacr(mgs) = Min( qsacr(mgs), qrmxd(mgs) ) +! csacr(mgs) = qsacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +! csacr(mgs) = min(csacr(mgs),crmxd(mgs)) + ELSE + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + + qsacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,ls,1) & + & + gf4*gf3*xdia(mgs,ls,2) ) & + & , qrmxd(mgs)) + ENDIF + ENDIF + end do +! +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' +! + do mgs = 1,ngscnt + qhacw(mgs) = 0.0 + rarx(mgs,lh) = 0.0 + vhacw(mgs) = 0.0 + vhsoak(mgs) = 0.0 + zhacw(mgs) = 0.0 + + IF ( .false. ) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lh,1) = Min( vtmax, vtxbar(mgs,lh,1)) + vtxbar(mgs,lh,2) = Min( vtmax, vtxbar(mgs,lh,2)) + vtxbar(mgs,lh,3) = Min( vtmax, vtxbar(mgs,lh,3)) + ENDIF + IF ( ehw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .ge. 2 ) THEN + + IF ( .false. ) THEN + qhacw(mgs) = (ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh)*pi* & + & abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* & + & (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + & + & xdia(mgs,lc,1)*gf73rds) + & + & xdia(mgs,lc,2)*gf83rds))/4. + + ELSE ! using Seifert coefficients + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) + + qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lc,lh)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) + + ENDIF + qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + +!! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +!! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + ENDIF + + ELSE + qhacw(mgs) = & + & min( & + & ((0.25)*pi)*ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) & + & , 0.5*(qx(mgs,lc)-qcwresv(mgs))*dtpinv) +! < , qxmxd(mgs,lc)) +! < , qcmxd(mgs)) + + + IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and. qhacw(mgs) > 0.0) THEN + qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh)) +! qaacw = Min( qaacw, 0.5*(qsacw(mgs) + qhacw(mgs) ) ) + qsacw(mgs) = qaacw + qhacw(mgs) = qaacw + ENDIF + + ENDIF + + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail + + IF ( temg(mgs) .lt. 273.15) THEN + IF ( irimdenopt == 1 ) THEN ! Heymsfield and Pflaum (1985) + vt = ( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) + + rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vt ) & + & /(temg(mgs)-273.15))**(rimc2) +! rimdn(mgs,lh) = Min( Max( hdnmn, rimc3, rimdn(mgs,lh) ), rimc4 ) + rimdn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) + +! IF ( igs(mgs) == 30 ) THEN +! write(0,*) 'k,vt: ',kgs(mgs),vt, vtxbar(mgs,lh,1),vtxbar(mgs,lh,2), rhovt(mgs)*axh(mgs)*( (alpha(mgs,lh)+3.)*xdia(mgs,lh,1) )**bxh(mgs) +! write(0,*) 'diam: char, mean, maxmass = ',xdia(mgs,lh,1),xdia(mgs,lh,3),(alpha(mgs,lh)+3.)*xdia(mgs,lh,1) +! write(0,*) 'ax,bx,cd,xdn = ',axh(mgs),bxh(mgs),cdxgs(mgs,lh),xdn(mgs,lh) +! write(0,*) 'vt_char,vt_mean = ',rhovt(mgs)*axh(mgs)*( xdia(mgs,lh,1) )**bxh(mgs),rhovt(mgs)*axh(mgs)*( xdia(mgs,lh,3) )**bxh(mgs) +! write(0,*) 'rimdn,alpha = ',rimdn(mgs,lh),alpha(mgs,lh) +! ENDIF + + ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993) + + tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & + & /(temg(mgs)-273.15)) + tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) ! have to limit range of "R" because quadratic function starts to decrease (unphysically) at higher values + + rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2) + + ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + + tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & + & /(temg(mgs)-273.15)) + ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + + ENDIF + ELSE + rimdn(mgs,lh) = 1000. + ENDIF + + IF ( lvol(lh) > 1 ) vhacw(mgs) = rho0(mgs)*qhacw(mgs)/rimdn(mgs,lh) + + ENDIF + + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .ge. 1 ) THEN + rarx(mgs,lh) = & + & qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh)) + ENDIF + + ENDIF + end do +! +! + do mgs = 1,ngscnt + qhaci(mgs) = 0.0 + qhaci0(mgs) = 0.0 + IF ( ehi(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + + qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + qhaci(mgs) = Min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) ) + ELSE + qhaci(mgs) = & + & min( & + & ((0.25)*pi)*ehi(mgs)*ehiclsn(mgs)*qx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do + + + IF ( lis > 1 .and. ipconc >= 5 ) THEN + do mgs = 1,ngscnt + qhacis(mgs) = 0.0 + qhacis0(mgs) = 0.0 + IF ( ehis(mgs) .gt. 0.0 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) + + qhacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*qx(mgs,lis)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lis,lh)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & da1(li)*xdia(mgs,lis,3)**2 ) + qhacis(mgs) = Min( ehis(mgs)*qhacis0(mgs), qxmxd(mgs,lis) ) + ENDIF + end do + ENDIF + +! +! + do mgs = 1,ngscnt + qhacs(mgs) = 0.0 + qhacs0(mgs) = 0.0 + IF ( ehs(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + + qhacs(mgs) = Min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) ) + + ELSE + qhacs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehs(mgs)*ehsclsn(mgs)*qx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qsmxd(mgs)) + ENDIF + ENDIF + end do +! + do mgs = 1,ngscnt + qhacr(mgs) = 0.0 + qhacrmlr(mgs) = 0.0 + vhacr(mgs) = 0.0 + chacr(mgs) = 0.0 + zhacr(mgs) = 0.0 + IF ( temg(mgs) .gt. tfr ) raindn(mgs,lh) = 1000.0 + + IF ( ehr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) +! qhacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) + + qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lr,lh)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + qhacr(mgs) = Min( qhacr(mgs), qxmxd(mgs,lr) ) + + qhacrmlr(mgs) = qhacr(mgs) + + IF ( temg(mgs) > tfr .and. iehr0c == 0 ) THEN + qhacr(mgs) = 0.0 + + IF ( iqhacrmlr == 0 ) THEN + qhacrmlr(mgs) = -qhacw(mgs) + ENDIF + + ELSE +! chacr(mgs) = Min( qhacr(mgs)*rho0(mgs)/xmas(mgs,lr), cxmxd(mgs,lr) ) + +! chacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : cx(mgs,lr)*0.25*pi* +! : (0.69874*xdia(mgs,lr,2) + +! : 1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) + +! chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* +! : ( da0lh(mgs)*xdia(mgs,lh,3)**2 + +! : dab0lh(mgs,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + +! : da0(lr)*xdia(mgs,lr,3)**2 ) + +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp + + chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + +! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacr(mgs) ) + ENDIF + ENDIF ! temg > tfr + + ELSE + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,lh,1) + ENDIF + + qhacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehr(mgs)*qx(mgs,lr)*cx(mgs,lh) & + & *abs(vt-vtxbar(mgs,lr,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qrmxd(mgs)) + + IF ( temg(mgs) > tfr ) THEN + IF ( iqhacrmlr >= 1 ) qhacrmlr(mgs) = qhacr(mgs) + qhacr(mgs) = 0.0 + ENDIF + + ENDIF + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail + + IF ( temg(mgs) .lt. 273.15) THEN + raindn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lr,3)) & + & *((0.60)*vt) & + & /(temg(mgs)-273.15))**(rimc2) + + raindn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) + ELSE + raindn(mgs,lh) = 1000. + ENDIF + + IF ( lvol(lh) > 1 ) vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh) + ENDIF + ENDIF + end do + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: hail collects xxxxx' +! + + do mgs = 1,ngscnt + qhlacw(mgs) = 0.0 + vhlacw(mgs) = 0.0 + vhlsoak(mgs) = 0.0 + IF ( lhl > 1 .and. .true.) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lhl,1) = Min( vtmax, vtxbar(mgs,lhl,1)) + vtxbar(mgs,lhl,2) = Min( vtmax, vtxbar(mgs,lhl,2)) + vtxbar(mgs,lhl,3) = Min( vtmax, vtxbar(mgs,lhl,3)) + ENDIF + + IF ( lhl > 0 ) THEN + rarx(mgs,lhl) = 0.0 + ENDIF + + IF ( lhl .gt. 1 .and. ehlw(mgs) .gt. 0.0 ) THEN + + +! IF ( ipconc .ge. 2 ) THEN + + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) + + qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lc,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) + + + qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + IF ( lvol(lhl) .gt. 1 ) THEN + + IF ( temg(mgs) .lt. 273.15) THEN + IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985) + rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,lhl) = Min( Max( hldnmn, rimc3, rimdn(mgs,lhl) ), rimc4 ) + + ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993) + tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & + & /(temg(mgs)-273.15) + tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2) + + ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & + & /(temg(mgs)-273.15) + ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + + ENDIF + ELSE + rimdn(mgs,lhl) = 1000. + ENDIF + + vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/rimdn(mgs,lhl) + + ENDIF + + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .ge. 1 ) THEN + rarx(mgs,lhl) = & + & qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl)) + ENDIF + + ENDIF + end do + + qhlaci(:) = 0.0 + qhlaci0(:) = 0.0 + IF ( lhl .gt. 1 ) THEN + do mgs = 1,ngscnt + IF ( ehli(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) + + qhlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,li,lhl)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + ! qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) ) + qhlaci(mgs) = Min( ehli(mgs)*qhlaci0(mgs), qimxd(mgs) ) + ENDIF + ENDIF + end do + ENDIF +! + qhlacs(:) = 0.0 + qhlacs0(:) = 0.0 + IF ( lhl .gt. 1 ) THEN + do mgs = 1,ngscnt + IF ( ehls(mgs) .gt. 0.0) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + + qhlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,ls,lhl)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + + qhlacs(mgs) = Min( ehls(mgs)*qhlacs0(mgs), qsmxd(mgs) ) + ENDIF + ENDIF + end do + ENDIF + + + do mgs = 1,ngscnt + qhlacr(mgs) = 0.0 + qhlacrmlr(mgs) = 0.0 + chlacr(mgs) = 0.0 + vhlacr(mgs) = 0.0 + IF ( lhl .gt. 1 .and. temg(mgs) .gt. tfr ) raindn(mgs,lhl) = 1000.0 + + IF ( lhl .gt. 1 .and. ehlr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) + + qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lr,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + qhlacr(mgs) = Min( qhlacr(mgs), qxmxd(mgs,lr) ) + + + IF ( iqhlacrmlr >= 1 ) qhlacrmlr(mgs) = qhlacr(mgs) + + IF ( temg(mgs) > tfr .and. iehlr0c == 0) THEN + qhlacr(mgs) = 0.0 + IF ( iqhlacrmlr == 0 ) THEN + qhlacrmlr(mgs) = -qhlacw(mgs) + ENDIF + ELSE + chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da0(lr)*xdia(mgs,lr,3)**2 ) + + chlacr(mgs) = min(chlacr(mgs),crmxd(mgs)) + + IF ( lvol(lhl) .gt. 1 ) THEN + vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/raindn(mgs,lhl) + ENDIF + ENDIF + ENDIF + ENDIF + end do + + + +! +! +! +! +! if (ndebug .gt. 0 ) write(0,*) 'Collection: Cloud collects xxxxx' + + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx2' +! + do mgs = 1,ngscnt + qiacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN + + vt = Sqrt((vtxbar(mgs,li,1)-vtxbar(mgs,lc,1))**2 + & + & 0.04*vtxbar(mgs,li,1)*vtxbar(mgs,lc,1) ) + + qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) + + qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) ) + ENDIF + end do + + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8' +! + do mgs = 1,ngscnt + qiacr(mgs) = 0.0 + qiacrf(mgs) = 0.0 + qiacrs(mgs) = 0.0 + ciacrs(mgs) = 0.0 + ciacr(mgs) = 0.0 + ciacrf(mgs) = 0.0 + viacrf(mgs) = 0.0 + csplinter(mgs) = 0.0 + qsplinter(mgs) = 0.0 + csplinter2(mgs) = 0.0 + qsplinter2(mgs) = 0.0 + IF ( iacr .ge. 1 .and. eri(mgs) .gt. 0.0 & + & .and. temg(mgs) .le. 270.15 ) THEN + IF ( ipconc .ge. 3 ) THEN + ni = 0.0 + IF ( xdia(mgs,li,1) .ge. 10.e-6 ) THEN + ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 ) + ENDIF + IF ( imurain == 1 ) THEN ! gamma of diameter + IF ( iacrsize /= 4 ) THEN + IF ( iacrsize .eq. 1 ) THEN + ratio = 500.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 2 ) THEN + ratio = 300.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 3 ) THEN + ratio = 40.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 5 ) THEN + ratio = 150.e-6/xdia(mgs,lr,1) + ENDIF + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) +! j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha + + nr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr) + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr) + + ELSE ! iacrsize == 4 : use all + nr = cx(mgs,lr) + qr = qx(mgs,lr) + ENDIF + + vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) + + qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1lh(mgs,lr,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) + + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + + + ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab0lh(mgs,lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & + & da0(lr)*xdia(mgs,lr,3)**2 ) + + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) + +! write(iunit,*) 'qiacr: ',cx(mgs,lr),nr,qx(mgs,lr),qr,qiacr(mgs),ciacr(mgs) +! write(iunit,*) 'xdia r li = ',xdia(mgs,lr,3),xdia(mgs,li,3),xdia(mgs,lr,1),xdia(mgs,li,1) +! write(iunit,*) 'i,j,ratio = ',i,j,ciacrratio(i,j),qiacrratio(i,j) +! write(iunit,*) 'ni,ci = ',ni,cx(mgs,li),qx(mgs,li) + + ELSEIF ( imurain == 3 ) THEN ! gamma of volume +! Set nr to the number of drops greater than 40 microns. + arg = 1000.*xdia(mgs,lr,3) +! nr = cx(mgs,lr)*gaml02( arg ) +! IF ( iacr .eq. 1 ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( iacrsize .eq. 1 ) THEN + nr = cx(mgs,lr)*gaml02d500( arg ) ! number greater than 500 microns in diameter + ELSEIF ( iacrsize .eq. 2 .or. iacrsize .eq. 5 ) THEN + nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter + ELSEIF ( iacrsize .eq. 3 ) THEN + nr = cx(mgs,lr)*gaml02( arg ) ! number greater than 40 microns in diameter + ELSEIF ( iacrsize .eq. 4 ) THEN + nr = cx(mgs,lr) ! all raindrops + ENDIF + ELSE + nr = cx(mgs,lr)*gaml02( arg ) + ENDIF +! ELSEIF ( iacr .eq. 2 ) THEN +! nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter +! ENDIF + IF ( ni .gt. 0.0 .and. nr .gt. 0.0 ) THEN + d0 = xdia(mgs,lr,3) + qiacr(mgs) = xdn(mgs,lr)*rhoinv(mgs)* & + & (0.217239*(0.522295*(d0**5) + & + & 49711.81*(d0**6) - & + & 1.673016e7*(d0**7)+ & + & 2.404471e9*(d0**8) - & + & 1.22872e11*(d0**9))*ni*nr) + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + ciacr(mgs) = & + & (0.217239*(0.2301947*(d0**2) + & + & 15823.76*(d0**3) - & + & 4.167685e6*(d0**4) + & + & 4.920215e8*(d0**5) - & + & 2.133344e10*(d0**6))*ni*nr) + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) +! ciacr(mgs) = qiacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + ENDIF + ENDIF + IF ( iacr .eq. 1 .or. iacr .eq. 3 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vr1mm*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 2 ) THEN + ciacrf(mgs) = ciacr(mgs) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 4 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vfrz*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 5 ) THEN + ciacrf(mgs) = ciacr(mgs)*rzxh(mgs) + ENDIF +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*27.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ENDIF + + + ELSE ! single-moment rain + qiacr(mgs) = & + & min( & + & ((0.25/gf4)*pi)*eri(mgs)*cx(mgs,li)*qx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf4*gf3*xdia(mgs,li,2) ) & + & , qrmxd(mgs)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then +! qiacr(mgs) = 0.0 +! ciacr(mgs) = 0.0 +! end if + + IF ( ipconc .ge. 1 ) THEN + IF ( nsplinter .ge. 1000 ) THEN + ! Lawson et al. 2015 JAS + ! ave. diam of freezing drops in microns + IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN + tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) ! avg. diameter of newly frozen drops in microns + csplinter(mgs) = lawson_splinter_fac*tmpdiam**4*ciacr(mgs) + ENDIF + ELSEIF ( nsplinter .ge. 0 ) THEN + csplinter(mgs) = nsplinter*ciacr(mgs) + ELSE + csplinter(mgs) = -nsplinter*ciacrf(mgs) + ENDIF + qsplinter(mgs) = Min(0.1*qiacr(mgs), csplinter(mgs)*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + ENDIF + + frach = 1.0 + IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN + IF ( ciacr(mgs) > qxmin(lh) ) THEN + xvfrz = rho0(mgs)*qiacr(mgs)/(ciacr(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) + + qiacrs(mgs) = (1.-frach)*qiacr(mgs) + ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) + + ENDIF + ENDIF + + qiacrf(mgs) = frach*qiacr(mgs) + ciacrf(mgs) = frach*ciacrf(mgs) + + IF ( lvol(lh) > 1 ) THEN + viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz + ENDIF + + end do +! +! +! +! + +! snow aggregation here + if ( ipconc .ge. 4 ) then ! + do mgs = 1,ngscnt + csacs(mgs) = 0.0 + IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 ) THEN ! .and. xv(mgs,ls) < 0.25*xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN + csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density + csacs(mgs) = min(csacs(mgs),csmxd(mgs)) + ENDIF + end do + end if +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 11' + if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then + do mgs = 1,ngscnt + ciacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN + ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc) + ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) + ENDIF + end do + + end if + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' + if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + cracw(mgs) = 0.0 + cracr(mgs) = 0.0 + ec0(mgs) = 1.e9 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) & + & .and. qracw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 ) THEN + cracw(mgs) = & + & ((0.25)*pi)*erw(mgs)*(cx(mgs,lc) - ccwresv(mgs))*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) & + & + gf3*xdia(mgs,lr,2) ) + ENDIF + ELSE ! IF ( ipconc .ge. 3 .and. + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN !{ + IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) +! IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6 +! DM0CCC=A2*XNC*XNR*(XVC+XVR) ! (A11) +! NOTE: murain drops out, so same result for imurain = 1 and 3 + cracw(mgs) = aa2*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))*(xv(mgs,lc) + xv(mgs,lr)) + ELSE + IF ( imurain == 3 ) THEN +! DM0CCC=A1*XNC*XNR*(((CNU+2.)/(CNU+1.))*XVC**2+((RNU+2.)/(RNU+1.))*XVR**2) ! (A13) + cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + ELSE ! imurain == 1 USE CP00 for rain DSD in diameter + cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) ) + ENDIF ! imurain + ENDIF + ENDIF ! } rh + ENDIF ! } dmrauto + ENDIF ! ipconc + ENDIF ! qc > qcmin & qr > qrmin + +! Rain self collection (cracr) and break-up (factor of ec0) +! +! + ec0(mgs) = 2.e9 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + ec0(mgs) = 0.0 + cracr(mgs) = 0.0 + ELSE + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + IF ( xdia(mgs,lr,3) .lt. 6.1e-4 ) THEN + ec0(mgs) = 1.0 + ELSE + ec0(mgs) = Exp(-50.0*(50.0*(xdia(mgs,lr,3) - 6.0e-4))) + ENDIF + + + IF ( rwrad .ge. 50.e-6 ) THEN + cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr) + ELSE + IF ( imurain == 3 ) THEN + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.) + ELSE ! imurain == 1 + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) + + ENDIF + ENDIF +! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) + ENDIF + ENDIF + ENDIF + +! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) + end do + end if +! +! +! +! Graupel +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + + IF ( ipconc .ge. 5 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN + +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chacw(mgs) = (ehw(mgs)*cx(mgs,lc)*cx(mgs,lh)*(pi/4.)* +! : abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) + +! chacw(mgs) = Min( chacw(mgs), 0.6*cx(mgs,lc)*dtpinv ) + +! chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmascw(mgs) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) + chacw(mgs) = Min( chacw(mgs), 0.5*(cx(mgs,lc) - ccwresv(mgs))*dtpinv ) + ELSE + qhacw(mgs) = 0.0 + ENDIF + ELSE + ! single-moment + chacw(mgs) = & + & ((0.25)*pi)*ehw(mgs)*cx(mgs,lc)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + chacw(mgs) = min(chacw(mgs),0.5*cx(mgs,lc)*dtpinv) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) +! chacw(mgs) = min(chacw(mgs),ccmxd(mgs)) + ENDIF + end do + end if +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chaci(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + + chaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) + + ELSE + chaci0(mgs) = & + & ((0.25)*pi)*ehiclsn(mgs)*cx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf1*xdia(mgs,li,2) & + & + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + ENDIF + + chaci(mgs) = min(ehi(mgs)*chaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if + + + chacis(:) = 0.0 + if ( lis > 1 .and. ipconc .ge. 5 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehis(mgs) .gt. 0.0 .or. ( ehisclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) + + chacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*cx(mgs,lis)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lis,lh)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & da0(lis)*xdia(mgs,lis,3)**2 ) + + + chacis(mgs) = min(ehis(mgs)*chacis0(mgs),cxmxd(mgs,lis)) + ENDIF + end do + end if +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' + chacs(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehs(mgs) .gt. 0 ) THEN + IF ( ipconc .ge. 5 .or. ( ehsclsn(mgs) > 0.0 .and. ipelec > 0 ) ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + chacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) + + ELSE + chacs0(mgs) = & + & ((0.25)*pi)*ehsclsn(mgs)*cx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf3*gf1*xdia(mgs,ls,2) & + & + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf1*gf3*xdia(mgs,lh,2) ) + ENDIF + chacs(mgs) = min(ehs(mgs)*chacs0(mgs),csmxd(mgs)) + ENDIF + end do + end if + + +! +! +! Hail +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chlacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + + IF ( lhl .gt. 1 .and. ipconc .ge. 5 ) THEN + IF ( qhlacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN + +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chlacw(mgs) = (ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)*(pi/4.)* +! : abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lhl,1)*(xdia(mgs,lhl,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) + +! chlacw(mgs) = Min( chlacw(mgs), 0.6*cx(mgs,lc)*dtpinv ) + +! chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmascw(mgs) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) + chlacw(mgs) = Min( chlacw(mgs), 0.5*cx(mgs,lc)*dtpinv ) + ELSE + qhlacw(mgs) = 0.0 + ENDIF +! ELSE +! chlacw(mgs) = +! > ((0.25)*pi)*ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) +! > *( gf1*xdia(mgs,lc,2) +! > + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) +! chlacw(mgs) = min(chlacw(mgs),0.5*cx(mgs,lc)*dtpinv) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) +! chlacw(mgs) = min(chlacw(mgs),ccmxd(mgs)) + ENDIF + end do + end if +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chlaci(:) = 0.0 + chlaci0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehli(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehliclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) + + chlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) + +! ELSE +! chlaci(mgs) = +! > ((0.25)*pi)*ehli(mgs)*cx(mgs,li)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1)) +! > *( gf1*xdia(mgs,li,2) +! > + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) + ENDIF + + chlaci(mgs) = min(ehli(mgs)*chlaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if + + + IF ( lis > 1 .and. ipconc .ge. 5) THEN + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chlacis(:) = 0.0 + chlacis0(:) = 0.0 + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehlis(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlisclsn(mgs) > 0.0) ) ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lis,1) ) + + chlacis0(mgs) = 0.25*pi*ehlisclsn(mgs)*cx(mgs,lhl)*cx(mgs,lis)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,lis)*xdia(mgs,lhl,3)*xdia(mgs,lis,3) + & + & da0(lis)*xdia(mgs,lis,3)**2 ) + + + chlacis(mgs) = min(ehlis(mgs)*chlacis0(mgs),cxmxd(mgs,lis)) + ENDIF + end do + ENDIF + +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj' + chlacs(:) = 0.0 + chlacs0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehls(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlsclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + + chlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) + +! ELSE +! chlacs(mgs) = +! > ((0.25)*pi)*ehls(mgs)*cx(mgs,ls)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1)) +! > *( gf3*gf1*xdia(mgs,ls,2) +! > + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lhl,1) +! > + gf1*gf3*xdia(mgs,lhl,2) ) + ENDIF + chlacs(mgs) = min(ehls(mgs)*chlacs0(mgs),csmxd(mgs)) + ENDIF + end do + end if + +! +! Ziegler (1985) autoconversion +! +! + IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion + if (ndebug .gt. 0 ) write(0,*) 'conc 26a' + + DO mgs = 1,ngscnt + zrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + crcnw(mgs) = 0.0 + cautn(mgs) = 0.0 + ENDDO + + DO mgs = 1,ngscnt +! qracw(mgs) = 0.0 +! cracw(mgs) = 0.0 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN + ! .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing + volb = xv(mgs,lc)*(1./(1.+alpha(mgs,lc)))**(1./2.) + cautn(mgs) = Min(ccmxd(mgs), & + & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) + cautn(mgs) = Max( 0.0d0, cautn(mgs) ) + IF ( rb(mgs) .le. 7.51d-6 ) THEN + t2s = 1.d30 +! cautn(mgs) = 0.0 + ELSE +! XL2P=2.7E-2*XNC*XVC*((1.E12*RB**3*RC)-0.4) + +! T2S=3.72E-3/(((1.E4*RB)-7.5)*XNC*XVC) +! t2s = 3.72E-3/(((1.e6*rb)-7.5)*cx(mgs,lc)*xv(mgs,lc)) +! t2s = 3.72/(((1.e6*rb(mgs))-7.5)*rho0(mgs)*qx(mgs,lc)) + t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc)) + + qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) ) + crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) ) + + IF ( dmrauto == 0 ) THEN + IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19) + crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs) + ELSEIF ( ( dmropt == 1 .or. dmropt == 3 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + crcnw(mgs) = Min(tmp,crcnw(mgs) ) + ELSEIF ( ( dmropt == 4 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr using converted qc mass + crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ELSEIF ( ( dmropt == 5 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr using full qc mass + crcnw(mgs) = (tmp*qx(mgs,lc)+tmp2*qx(mgs,lr))/(qx(mgs,lc)+qx(mgs,lr)) + ELSEIF ( ( dmropt == 6 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass*diameter-weighted average of old and new Dmr (using full qc mass) + crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/(xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) + ELSEIF ( ( dmropt == 7 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try diameter-weighted average of old and new Dmr + crcnw(mgs) = (tmp*xdia(mgs,lc,3)+tmp2*xdia(mgs,lr,3))/(xdia(mgs,lc,3)+xdia(mgs,lr,3)) + ELSEIF ( ( dmropt == 8 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try sqrt(diameter)-weighted average of old and new Dmr + crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/(sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) + ENDIF + ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN + IF ( qx(mgs,lr) > qxmin(lr) ) THEN + tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + crcnw(mgs) = Min(tmp,crcnw(mgs) ) + ENDIF + ELSEIF ( dmrauto == 2 .and. cx(mgs,lr) > cxmin) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr + crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ELSEIF ( dmrauto == 3 .and. cx(mgs,lr) > cxmin) THEN ! adapted from MY/CP code + tmp = Max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) ) + crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3) + ENDIF + + IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 + +! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) +! : THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s,qx(mgs,lr) +! write(0,*) ' ',qx(mgs,lc),cx(mgs,lc),0.5e6*xdia(mgs,lc,1) +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3/(4.*pi))*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.),rh(mgs)*1.e6,rwrad(mgs) +! ELSEIF ( crcnw(mgs) .gt. 1.0 .and. cautn(mgs) .gt. 0.) THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3*pi/4.)*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.) +! ENDIF +! crcnw(mgs) = Min(cautn(mgs),3.5e9*xl2p(mgs)/t2s) + +! IF ( qrcnw(mgs) .gt. 0.3e-2 ) THEN +! write(0,*) 'QRCNW' +! write(0,*) qrcnw(mgs),crcnw(mgs),cautn(mgs) +! write(0,*) xl2p,t2s,rho0(mgs),xv(mgs,lc),cx(mgs,lc),qx(mgs,lc) +! write(0,*) rb,0.5*xdia(mgs,lc,1),mgs,igs(mgs),kgs(mgs) +! ENDIF +! qrcnw(mgs) = Min(qrcnw(mgs),qcmxd(mgs)) + ENDIF + + + ENDIF + ENDDO + + + + ELSE + +! +! Berry 1968 auto conversion for rain (Orville & Kopp 1977) +! +! + if ( ircnw .eq. 4 ) then + do mgs = 1,ngscnt +! sconvmix(lcw,mgs) = 0.0 + qrcnw(mgs) = 0.0 + qdiff = max((qx(mgs,lc)-qminrncw),0.0) + if ( qdiff .gt. 0.0 .and. xdia(mgs,lc,1) .gt. 20.0e-6 ) then + argrcnw = & + & ((1.2e-4)+(1.596e-12)*(cx(mgs,lc)*1.0e-6) & + & /(cwdisp*qdiff*1.0e-3*rho0(mgs))) + qrcnw(mgs) = (rho0(mgs)*1e-3)*(qdiff**2)/argrcnw +! sconvmix(lcw,mgs) = max(sconvmix(lcw,mgs),0.0) + qrcnw(mgs) = (max(qrcnw(mgs),0.0)) + end if + end do + + ENDIF +! +! +! +! Berry 1968 auto conversion for rain (Ferrier 1994) +! +! + if ( ircnw .eq. 5 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + qccrit = (pi/6.)*(cx(mgs,lc)*cwdiap**3)*xdn(mgs,lc)/rho0(mgs) + qdiff = max((qx(mgs,lc)-qccrit),0.) + if ( qdiff .gt. 0.0 .and. cx(mgs,lc) .gt. 1.0 ) then + argrcnw = & +! > ((1.2e-4)+(1.596e-12)*cx(mgs,lc)/(cwdisp*rho0(mgs)*qdiff)) & + & ((1.2e-4)+(1.596e-12)*cx(mgs,lc)*1.0e-3/(cwdisp*rho0(mgs)*qdiff)) + qrcnw(mgs) = & +! > timflg(mgs)*rho0(mgs)*(qdiff**2)/argrcnw & + & 1.0e-3*rho0(mgs)*(qdiff**2)/argrcnw + qrcnw(mgs) = Min(qxmxd(mgs,lc), (max(qrcnw(mgs),0.0)) ) + +! write(iunit,*) 'qrcnw,cx =',qrcnw(mgs),cx(mgs,lc),mgs,1.e3*qx(mgs,lc),cno(lr) + end if + end do + end if + +! +! +! kessler auto conversion for rain. +! + if ( ircnw .eq. 2 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + qrcnw(mgs) = (0.001)*max((qx(mgs,lc)-qminrncw),0.0) + end do + end if +! +! c4 = pi/6 +! c1 = 0.12-0.32 for colorado storms...typically 0.3-0.4 +! berry reinhart type conversion (proctor 1988) +! + if ( ircnw .eq. 1 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + c1 = 0.2 + c4 = pi/(6.0) + bradp = & + & (1.e+06) * ((c1/(0.38))**(1./3.)) * (xdia(mgs,lc,1)*(0.5)) + bl2 = & + & (0.027) * ((100.0)*(bradp**3)*(xdia(mgs,lc,1)*(0.5)) - (0.4)) + bt2 = (bradp -7.5) / (3.72) + qrcnw(mgs) = 0.0 + if ( bl2 .gt. 0.0 .and. bt2 .gt. 0.0 ) then + qrcnw(mgs) = bl2 * bt2 * rho0(mgs) & + & * qx(mgs,lc) * qx(mgs,lc) + end if + end do + end if + + + + ENDIF ! ( ipconc .ge. 2 ) + +! +! +! +! Bigg Freezing of Rain +! + if (ndebug .gt. 0 ) write(0,*) 'conc 27a' + qrfrz(:) = 0.0 + qrfrzs(:) = 0.0 + qrfrzf(:) = 0.0 + vrfrzf(:) = 0.0 + crfrz(:) = 0.0 + crfrzs(:) = 0.0 + crfrzf(:) = 0.0 + zrfrz(:) = 0.0 + zrfrzs(:) = 0.0 + zrfrzf(:) = 0.0 + qwcnr(:) = 0.0 + + IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. .and. ibiggopt > 0 ) then +! brz = 100.0 +! arz = 0.66 + IF ( ipconc .lt. 3 ) THEN + qrfrz(mgs) = & + & min( & + & (20.0)*(pi**2)*brz*(xdn(mgs,lr)/rho0(mgs)) & + & *cx(mgs,lr)*(xdia(mgs,lr,1)**6) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & , qrmxd(mgs)) + qrfrzf(mgs) = qrfrz(mgs) + +! ELSEIF ( ipconc .ge. 3 .and. xv(mgs,lr) .gt. 1.1*xvmn(lr) ) THEN + ELSEIF ( ipconc .ge. 3 ) THEN +! tmp = brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! crfrz(mgs) = xv(mgs,lr)*tmp + + frach = 1.0d0 + +! IF ( ibiggopt == 2 .and. imurain == 1 .and. lzr < 1 ) THEN ! lzr check because results are weird for 3-moment + IF ( ibiggopt == 2 .and. imurain == 1 ) THEN ! + ! integrate from Bigg diameter (for given supercooling Ts) to infinity + + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b, where a = 6.9/6.8, or approx a = 1.0, and b = 16.2 + ! volt is given in cm**3, so convert to m**3 + dbigg = (6./pi* volt )**(1./3.) + + ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. + + ratio = Min(maxratiolu, dbigg/xdia(mgs,lr,1) ) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + IF ( alp0flag ) THEN + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + ELSE + j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + ENDIF + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha; + + crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv + crfrzf(mgs) = crfrz(mgs) + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv + qrfrzf(mgs) = qrfrz(mgs) + + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN + ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) + crfrzf(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + crfrzs(mgs) = crfrz(mgs) + qrfrzs(mgs) = qrfrz(mgs) + + ELSEIF ( dbigg < Max(dfrz,dhmn) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals + ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! + + crfrzs(mgs) = crfrz(mgs) + qrfrzs(mgs) = qrfrz(mgs) + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 1.2*xvmn(lr) ) THEN + ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) + crfrzf(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + + + ELSE !{ + + ! recalculate using dhmn for ratio + ratio = Min( maxratiolu, Max(dfrz,dhmn)/xdia(mgs,lr,1) ) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) +! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) +! j = Int(Max(alphamin,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) + IF ( alp0flag ) THEN + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + ELSE + j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + ENDIF + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + + ! interpolate along alpha; + + crfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv + + ! now subtract off the difference + crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) + qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) + + ENDIF ! } + ELSE + crfrzs(mgs) = 0.0 + qrfrzs(mgs) = 0.0 + ENDIF ! } + + IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN + fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) + qrfrz(mgs) = fac*qrfrz(mgs) + qrfrzs(mgs) = fac*qrfrzs(mgs) + qrfrzf(mgs) = fac*qrfrzf(mgs) + crfrz(mgs) = fac*crfrz(mgs) + crfrzs(mgs) = fac*crfrzs(mgs) + crfrzf(mgs) = fac*crfrzf(mgs) + ENDIF +! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN +! fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr) +! crfrz(mgs) = fac*crfrz(mgs) +! crfrzs(mgs) = fac*crfrzs(mgs) +! ENDIF + +! qrfrzf(mgs) = qrfrz(mgs) +! crfrzf(mgs) = crfrz(mgs) + + ! qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs) + ! crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs) + + + ELSEIF ( ibiggopt == 1 ) THEN + ! Z85, eq. A34 + tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) + IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN ! { +! write(iunit,*) 'Bigg Freezing problem!',mgs,igs(mgs),kgs(mgs) +! write(iunit,*) 'tmp, cx(lr), xv = ',tmp, cx(mgs,lr), xv(mgs,lr), (Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! write(iunit,*) 'qr,temcg = ',qx(mgs,lr)*1000.,temcg(mgs) + crfrz(mgs) = cxmxd(mgs,lr) ! cx(mgs,lr)*dtpinv + qrfrz(mgs) = qxmxd(mgs,lr) ! qx(mgs,lr)*dtpinv +! STOP + ELSE ! } { + crfrz(mgs) = tmp + ! crfrzfmx = cx(mgs,lr)*Exp(-4./3.*pi*(40.e-6)**3/xv(mgs,lr)) + ! IF ( crfrz(mgs) .gt. crfrzmx ) THEN + ! crfrz(mgs) = crfrzmx + ! qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrzmx + ! qwcnr(mgs) = cx(mgs,lr) - crfrzmx + ! ELSE + IF ( lzr < 1 ) THEN + IF ( imurain == 3 ) THEN + bfnu = bfnu0 + ELSE !imurain == 1 + bfnu = bfnu1 + ENDIF + ELSE + ! bfnu = 1.0 ! (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + IF ( imurain == 3 ) THEN + bfnu = (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + ELSE !imurain == 1 +! bfnu = bfnu1 + bfnu = (4. + alpha(mgs,lr))*(5. + alpha(mgs,lr))*(6. + alpha(mgs,lr))/ & + & ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr))) +! bfnu = 1. + ENDIF + ENDIF + qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs) + + qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) + crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)*dtpinv ) !cxmxd(mgs,lr) + qrfrz(mgs) = Min( qrfrz(mgs), qx(mgs,lr) ) + qrfrzf(mgs) = qrfrz(mgs) + ENDIF !} + + + + + IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN !{ Yes, it compares cx and qxmin, but this is just to be sure that + ! crfrz is greater than zero in the division +! IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN +! IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN + + IF ( (ibiggsnow == 1 .or. ibiggsnow == 3 ) .and. ibiggopt /= 2 ) THEN + xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) + + qrfrzs(mgs) = (1.-frach)*qrfrz(mgs) + crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs) +! qrfrzf(mgs) = frach*qrfrz(mgs) + + ENDIF + + IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN + qrfrzs(mgs) = qrfrz(mgs) + crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs) + ELSE +! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)*dtpinv ) ! cxmxd(mgs,lr) +! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) + qrfrzf(mgs) = frach*qrfrz(mgs) +! crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) ) + IF ( ibfr .le. 1 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 5 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) )*rzxh(mgs) !*crfrz(mgs) + ELSEIF ( ibfr .eq. 2 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 6 ) THEN + crfrzf(mgs) = frach*Max(crfrz(mgs), qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSE + crfrzf(mgs) = frach*crfrz(mgs) + ENDIF +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN +! crfrzf(mgs) = crfrz(mgs) +! ENDIF + + ENDIF +! crfrz(mgs) = Min( cxmxd(mgs,lr), rho0(mgs)*qrfrz(mgs)/xmas(mgs,lr) ) + ELSE + crfrz(mgs) = 0.0 + qrfrz(mgs) = 0.0 + ENDIF !} + + ENDIF ! ibiggopt + + IF ( lvol(lh) .gt. 1 ) THEN + vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz + ENDIF + + + IF ( nsplinter .ne. 0 ) THEN + IF ( nsplinter .ge. 1000 ) THEN + ! Lawson et al. 2015 JAS + ! ave. diam of freezing drops in microns + tmp = 0 + IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN + tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.) ! avg. diameter of newly frozen drops in microns + tmp = lawson_splinter_fac*tmpdiam**4*crfrz(mgs) + ENDIF + ELSEIF ( nsplinter .gt. 0 ) THEN + tmp = nsplinter*crfrz(mgs) + ELSE + tmp = -nsplinter*crfrzf(mgs) + ENDIF + csplinter2(mgs) = tmp + qsplinter2(mgs) = Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + +! csplinter(mgs) = csplinter(mgs) + tmp +! qsplinter(mgs) = qsplinter(mgs) + Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + ENDIF +! IF ( temcg(mgs) .lt. -31.0 ) THEN +! qrfrz(mgs) = qx(mgs,lr)*dtpinv + qrcnw(mgs) +! qrfrzf(mgs) = qrfrz(mgs) +! crfrz(mgs) = cx(mgs,lr)*dtpinv + crcnw(mgs) +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! ENDIF +! qrfrz(mgs) = 6.0*xdn(mgs,lr)*xv(mgs,lr)**2*tmp*rhoinv(mgs) +! qrfrz(mgs) = Min( qrfrz(mgs), ffrz*qrmxd(mgs) ) +! crfrz(mgs) = Min( crmxd(mgs), ffrz*crfrz(mgs)) +! crfrz(mgs) = Min(crmxd(mgs),qrfrz(mgs)*rho0(mgs)/xmas(mgs,lr)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then + else +! end if + end if + end do + + ENDIF +! +! Homogeneous freezing of cloud drops to ice crystals +! following Bigg (1953) and Ferrier (1994). +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25b' + do mgs = 1,ngscnt + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + qwfrzc(mgs) = 0.0 + cwfrzc(mgs) = 0.0 + qwfrzp(mgs) = 0.0 + cwfrzp(mgs) = 0.0 + IF ( ibfc .ge. 1 .and. ibfc /= 3 .and. temg(mgs) < 268.15 ) THEN +! if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1. .and. & +! & .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then + if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN + IF ( ipconc < 2 ) THEN + qwfrz(mgs) = ((2.0)*(brz)/(xdn(mgs,lc)*cx(mgs,lc))) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & *rho0(mgs)*(qx(mgs,lc)**2) + qwfrz(mgs) = max(qwfrz(mgs), 0.0) + qwfrz(mgs) = min(qwfrz(mgs),qcmxd(mgs)) + cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li) + ELSEIF ( ipconc .ge. 2 ) THEN + IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 +! dbigg = (6./pi* volt )**(1./3.) + + IF ( alpha(mgs,lc) == 0.0 ) THEN + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))*dtpinv ! number of droplets with volume greater than volt +!turn off limit so that all can freeze at low temp +!!! cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs)) + + qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + ELSE + ratio = (1. + alpha(mgs,lc))*volt/xv(mgs,lc) + + IF ( .false. .and. usegamxinfcnu ) THEN + i = Nint(dgami*(1. + alpha(mgs,lc))) + gcnup1 = gmoi(i) + i = Nint(dgami*(2. + alpha(mgs,lc))) + gcnup2 = gmoi(i) + + cwfrz(mgs) = cx(mgs,lc)*Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1) + + qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) + + ELSE + + ratio = Min( maxratiolu, ratio ) +! write(0,*) 'cwfrz: temp,ratio = ',temcg(mgs),ratio +! write(0,*) 'cwfrz: xv,volt,qx = ',xv(mgs,lc),volt,qx(mgs,lc) +! write(0,*) 'cwfrz: i,j,k = ',igs(mgs),jgs,kgs(mgs) + tmp = gaminterp(ratio,alpha(mgs,lc),1,1) +! write(0,*) 'cwfrz: tmp1 = ',tmp + cwfrz(mgs) = cx(mgs,lc)*tmp*dtpinv ! Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1) + + tmp = gaminterp(ratio,alpha(mgs,lc),12,1) +! write(0,*) 'cwfrz: tmp2 = ',tmp + qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*dtpinv*tmp ! Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) + + ENDIF + + ENDIF + + ENDIF + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + end if + end if + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qwfrzp(mgs) = qwfrz(mgs) + cwfrzp(mgs) = cwfrz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwfrzc(mgs) = qwfrz(mgs) + cwfrzc(mgs) = cwfrz(mgs) + end if + +! +! qwfrzp(mgs) = 0.0 +! qwfrzc(mgs) = qwfrz(mgs) +! + end do +! +! +! Contact freezing nucleation: factor is to convert from L-1 +! T < -2C: via Meyers et al. JAM July, 1992 (31, 708-721) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25a' + do mgs = 1,ngscnt + + ccia(mgs) = 0.0 + + cwctfz(mgs) = 0.0 + qwctfz(mgs) = 0.0 + ctfzbd(mgs) = 0.0 + ctfzth(mgs) = 0.0 + ctfzdi(mgs) = 0.0 + + cwctfzc(mgs) = 0.0 + qwctfzc(mgs) = 0.0 + cwctfzp(mgs) = 0.0 + qwctfzp(mgs) = 0.0 + IF ( icfn .ge. 1 ) THEN + + IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + +! find available # of ice nuclei & limit value to max depletion of cloud water + + IF ( icfn .ge. 2 ) THEN + ccia(mgs) = exp( 4.11 - (0.262)*temcg(mgs) ) ! in m-3, see Walko et al. 1995; 1000*exp(-2.8 -b*t) = exp(6.91)*exp(-2.8 - b*t) = exp(4.11 -b*t) + !ccia(mgs) = Min(cwctfz(mgs), ccmxd(mgs) ) + +! now find how many of these collect cloud water to form IN +! Cotton et al 1986 + + knud(mgs) = 2.28e-5 * temg(mgs) / ( pres(mgs)*raero ) !Walko et al. 1995 + knuda(mgs) = 1.257 + 0.4*exp(-1.1/knud(mgs)) !Pruppacher & Klett 1997 eqn 11-16 + gtp(mgs) = 1. / ( fai(mgs) + fbi(mgs) ) !Byers 65 / Cotton 72b + dfar(mgs) = kb*temg(mgs)*(1.+knuda(mgs)*knud(mgs))/(6.*pi*fadvisc(mgs)*raero) !P&K 1997 eqn 11-15 + fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs) + fn2(mgs) = -gtp(mgs)*(ssw(mgs)-1.)*felv(mgs)/pres(mgs) + fnft(mgs) = 0.4*(1.+1.45*knud(mgs)+0.4*knud(mgs)*exp(-1./knud(mgs)))*(ftka(mgs)+2.5*knud(mgs)*kaero) & + & / ( (1.+3.*knud(mgs))*(2*ftka(mgs)+5.*knud(mgs)*kaero+kaero) ) + + +! Brownian diffusion + ctfzbd(mgs) = fn1(mgs)*dfar(mgs) + +! Thermophoretic contact nucleation + ctfzth(mgs) = fn1(mgs)*fn2(mgs)*fnft(mgs)/rho0(mgs) + +! Diffusiophoretic contact nucleation + ctfzdi(mgs) = fn1(mgs)*fn2(mgs)*rw*temg(mgs)/(felv(mgs)*rho0(mgs)) + + cwctfz(mgs) = max( ctfzbd(mgs) + ctfzth(mgs) + ctfzdi(mgs) , 0.) + +! Sum of the contact nucleation processes +! IF ( cx(mgs,lc) .gt. 1.e6) write(0,*) 'ctfzbd,etc = ',cwctfz(mgs),ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs) +! IF ( wvel(mgs) .lt. -0.05 ) write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs) +! IF ( ssw(mgs) .lt. 1.0 .and. cx(mgs,lc) .gt. 1.e6 .and. cwctfz(mgs) .gt. 1. ) THEN +! write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs),fn1(mgs),fn2(mgs) +! write(6,*) 'more = ',nstep,ssw(mgs),dfar(mgs),gtp(mgs),felv(mgs),pres(mgs) +! ENDIF + + ELSEIF ( icfn .eq. 1 ) THEN + IF ( wvel(mgs) .lt. -0.05 ) THEN ! older kludgy version + cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) ) + cwctfz(mgs) = Min((1.0e3)*cwctfz(mgs), ccmxd(mgs) ) !convert to m-3 + ENDIF + ENDIF ! icfn + + IF ( ipconc .ge. 2 ) THEN + cwctfz(mgs) = Min( cwctfz(mgs)*dtpinv, ccmxd(mgs) ) + qwctfz(mgs) = xmas(mgs,lc)*cwctfz(mgs)/rho0(mgs) + ELSE + qwctfz(mgs) = (cimasn)*cwctfz(mgs)/(dtp*rho0(mgs)) + qwctfz(mgs) = max(qwctfz(mgs), 0.0) + qwctfz(mgs) = min(qwctfz(mgs),qcmxd(mgs)) + ENDIF + +! + if ( xplate(mgs) .eq. 1 ) then + qwctfzp(mgs) = qwctfz(mgs) + cwctfzp(mgs) = cwctfz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwctfzc(mgs) = qwctfz(mgs) + cwctfzc(mgs) = cwctfz(mgs) + end if + +! IF ( cwctfz(mgs)*dtp > 0.5 .and. dtp*qwctfz(mgs) > qxmin(li) ) THEN +! write(91,*) 'cwctfz: ',cwctfz(mgs),qwctfz(mgs) ! ,cwctfzc(mgs),qwctfzc(mgs) +! ENDIF + +! +! qwctfzc(mgs) = qwctfz(mgs) +! qwctfzp(mgs) = 0.0 +! + end if + + ENDIF ! icfn + + end do +! +! +! +! Hobbs-Rangno ice enhancement (Ferrier, 1994) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 23a' + dthr = 300.0 + hrifac = (1.e-3)*((0.044)*(0.01**3)) + do mgs = 1,ngscnt + ciihr(mgs) = 0.0 + qiihr(mgs) = 0.0 + cicichr(mgs) = 0.0 + qicichr(mgs) = 0.0 + cipiphr(mgs) = 0.0 + qipiphr(mgs) = 0.0 + IF ( ihrn .ge. 1 ) THEN + if ( qx(mgs,lc) .gt. qxmin(lc) ) then + if ( temg(mgs) .lt. 273.15 ) then +! write(iunit,'(3(1x,i3),3(1x,1pe12.5))') +! : igs(mgs),jgs,kgs(mgs),cx(mgs,lc),rho0(mgs),qx(mgs,lc) +! write(iunit,'(1pe15.6)') +! : log(cx(mgs,lc)*(1.e-6)/(3.0)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc)), +! : (cx(mgs,lc)*(1.e-6)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)), +! : (alog(cx(mgs,lc)*(1.e-6)/(3.0)) * +! > ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6))) + + IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN + ciihr(mgs) = ((1.69e17)/dthr) & + & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) * & + & ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.) + ciihr(mgs) = ciihr(mgs)*(1.0e6) + qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs) + qiihr(mgs) = max(qiihr(mgs), 0.0) + qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs)) + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qipiphr(mgs) = qiihr(mgs) + cipiphr(mgs) = ciihr(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qicichr(mgs) = qiihr(mgs) + cicichr(mgs) = ciihr(mgs) + end if +! +! qipiphr(mgs) = 0.0 +! qicichr(mgs) = qiihr(mgs) +! + end if + end if + ENDIF ! ihrn + end do +! +! +! +! simple frozen rain to hail conversion. All of the +! frozen rain larger than 5.0e-3 m in diameter are converted +! to hail. This is done by considering the equation for +! frozen rain mixing ratio: +! +! +! qfw = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! /inf +! * | fwdia*3 exp(-dia/fwdia) d(dia) +! /Do +! +! The amount to be reclassified as hail is the integral above from +! Do to inf where Do is 5.0e-3 m. +! +! +! qfauh = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! + + + hdia0 = 300.0e-6 + do mgs = 1,ngscnt + qscnvi(mgs) = 0.0 + cscnvi(mgs) = 0.0 + cscnvis(mgs) = 0.0 +! IF ( .false. ) THEN +! IF ( temg(mgs) .lt. tfr .and. ssi(mgs) .gt. 1.01 .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( temg(mgs) .lt. tfr .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( ipconc .ge. 4 .and. .false. ) THEN + if ( cx(mgs,li) .gt. 10. .and. xdia(mgs,li,1) .gt. 50.e-6 ) then !{ + cirdiatmp = & + & (qx(mgs,li)*rho0(mgs) & + & /(pi*xdn(mgs,li)*cx(mgs,li)))**(1./3.) + IF ( cirdiatmp .gt. 100.e-6 ) THEN !{ + qscnvi(mgs) = & + & ((pi*xdn(mgs,li)*cx(mgs,li)) / (6.0*rho0(mgs)*dtp)) & + & *exp(-hdia0/cirdiatmp) & + & *( (hdia0**3) + 3.0*(hdia0**2)*cirdiatmp & + & + 6.0*(hdia0)*(cirdiatmp**2) + 6.0*(cirdiatmp**3) ) + qscnvi(mgs) = & + & min(qscnvi(mgs),qimxd(mgs)) + IF ( ipconc .ge. 4 ) THEN + cscnvi(mgs) = Min( cimxd(mgs), cx(mgs,li)*Exp(-hdia0/cirdiatmp)) + ENDIF + ENDIF ! } + end if ! } + + ELSEIF ( ipconc .lt. 4 ) THEN + + qscnvi(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscnvi(mgs) = min(qscnvi(mgs),qxmxd(mgs,li)) + cscnvi(mgs) = qscnvi(mgs)*rho0(mgs)/xmas(mgs,li) + cscnvis(mgs) = 0.5*cscnvi(mgs) + + ENDIF + ENDIF +! ENDIF + end do + + + +! +! Ventilation coeficients +! + do mgs = 1,ngscnt + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + end do +! +! + if ( ndebug .gt. 0 ) write(0,*) 'civent' +! + civenta = 1.258e4 + civentb = 2.331 + civentc = 5.662e4 + civentd = 2.373 + civente = 0.8241 + civentf = -0.042 + civentg = 1.70 + + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + cireyn = & + & (civenta*xdia(mgs,li,1)**civentb & + & +civentc*xdia(mgs,li,1)**civentd) & + & / & + & (civente*xdia(mgs,li,1)**civentf+civentg) + xcivent = (fschm(mgs)**(1./3.))*((cireyn/fakvisc(mgs))**0.5) + if ( xcivent .lt. 1.0 ) then + civent(mgs) = 1.0 + 0.14*xcivent**2 + end if + if ( xcivent .ge. 1.0 ) then + civent(mgs) = 0.86 + 0.28*xcivent + end if + ELSE + civent(mgs) = 0.0 + ENDIF + + + ENDIF ! icond .eq. 1 + end do + +! +! + igmrwa = 100.0*2.0 + igmrwb = 100.*((5.0+br)/2.0) + rwventa = (0.78)*gmoi(igmrwa) ! 0.78 + rwventb = (0.308)*gmoi(igmrwb) ! 0.562825 + do mgs = 1,ngscnt + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + + ELSE ! imurain == 1 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lr) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( iferwisventr == 1 ) THEN + + ! Ferrier fall speed in the ventillation term [uses fx(lr) ] + + alpr = Min(alpharmax,alpha(mgs,lr) ) + + x = 1. + alpha(mgs,lr) + + IF ( lzr > 1 ) THEN ! 3 moment +! + ELSE + y = ventrxn(mgs) + ENDIF + +! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK +! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK + vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula -- should be equivalent) + vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) + + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + + + ENDIF ! iferwisventr + + ENDIF ! imurain + ELSE + rwvent(mgs) = & + & (rwventa + rwventb*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + ELSE + rwvent(mgs) = 0.0 + ENDIF + end do +! + igmswa = 100.0*2.0 + igmswb = 100.*((5.0+ds)/2.0) + swventa = (0.78)*gmoi(igmswa) + swventb = (0.308)*gmoi(igmswb) + do mgs = 1,ngscnt + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + swvent(mgs) = 0.65 + 0.44*fvent(mgs)*Sqrt(vtxbar(mgs,ls,1)*xdia(mgs,ls,1)) + ELSE +! 10-ice version: + swvent(mgs) = & + & (swventa + swventb*fvent(mgs) & + & *Sqrt((cs*rhovt(mgs))) & + & *(xdia(mgs,ls,1)**((1.0+ds)/2.0)) ) + ENDIF + ELSE + swvent(mgs) = 0.0 + ENDIF + end do +! +! + + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) +! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25) + IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN + hwvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lh)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lh,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lh) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! note that hwvent includes a division by Gamma(1+alpha), so Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y + x = 1. + alpha(mgs,lh) + + tmp = 1 + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lh) + 0.5*bxh(mgs) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp + + + hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxh(mgs)))*Sqrt(axh(mgs)*rhovt(mgs)) + hwvent(mgs) = & + & ( 0.78*x + y*hwventy(mgs) ) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxh(mgs)))* & +! & Sqrt(axh(mgs)*rhovt(mgs)) ) + + ENDIF + ELSE + hwvent(mgs) = 0.0 + hwventy(mgs) = 0.0 + ENDIF + end do + + hlvent(:) = 0.0 + hlventy(:) = 0.0 + + IF ( lhl .gt. 1 ) THEN + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) +! hwventc = (4.0*gr/(3.0*cdx(lhl)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25) + + IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN + hlvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lhl)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lhl,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lhl) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! note that hlvent includes a division by Gamma(1+alpha), so x = Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y + + x = 1. + alpha(mgs,lhl) + + tmp = 1 + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxhl(mgs) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + + hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxhl(mgs)))*Sqrt(axhl(mgs)*rhovt(mgs)) + + hlvent(mgs) = 0.78*x + y*hlventy(mgs) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxhl(mgs)))* & +! & Sqrt(axhl(mgs)*rhovt(mgs))) +! : Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp + + ENDIF + ENDIF + end do + ENDIF + +! +! +! +! Wet growth constants +! + do mgs = 1,ngscnt + fwet1(mgs) = & + & (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs) ) & + & / ( rho0(mgs)*(felf(mgs)+fcw(mgs)*temcg(mgs)) ) + fwet2(mgs) = & + & (1.0)-fci(mgs)*temcg(mgs) & + & / ( felf(mgs)+fcw(mgs)*temcg(mgs) ) + end do +! +! Melting constants +! + do mgs = 1,ngscnt + fmlt1(mgs) = (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) & + & / (felf(mgs)) + fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) + end do +! +! Vapor Deposition constants +! + do mgs = 1,ngscnt + fvds(mgs) = & + & (4.0*pi/rho0(mgs))*(ssi(mgs)-1.0)* & + & (1.0/(fai(mgs)+fbi(mgs))) + end do + do mgs = 1,ngscnt + fvce(mgs) = & + & (4.0*pi/rho0(mgs))*(ssw(mgs)-1.0)* & + & (1.0/(fav(mgs)+fbv(mgs))) + end do + +! +! deposition, sublimation, and melting of snow, graupel and hail +! + qsmlr(:) = 0.0 + qimlr(:) = 0.0 ! this is not used. qi melts to qc way down in the code. + qhmlr(:) = 0.0 + qhlmlr(:) = 0.0 + IF ( lhwlg > 1 ) THEN + qhmlrlg(:) = 0.0 + qhlmlrlg(:) = 0.0 + ENDIF + qhfzh(:) = 0.0 + qhlfzhl(:) = 0.0 + qhfzhlg(:) = 0.0 + qhlfzhllg(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + qsfzs(:) = 0.0 + zsmlr(:) = 0.0 + zhmlr(:) = 0.0 + zhmlrr(:) = 0.0 + zhshr(:) = 0.0 + zhlmlr(:) = 0.0 + zhlshr(:) = 0.0 + + zhshrr(:) = 0.0 + zhlmlrr(:) = 0.0 + zhlshrr(:) = 0.0 + + csmlr(:) = 0.0 + csmlrr(:) = 0.0 + chmlr(:) = 0.0 + chmlrr(:) = 0.0 + chlmlr(:) = 0.0 +! chlmlrsave(:) = 0.0 +! qhlmlrsave(:) = 0.0 +! chlsave(:) = 0.0 +! qhlsave(:) = 0.0 + chlmlrr(:) = 0.0 + + if ( .not. mixedphase ) then !{ + do mgs = 1,ngscnt +! + IF ( temg(mgs) .gt. tfr ) THEN + + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + qsmlr(mgs) = & + & min( & + & (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & ! /rhosm & + & , 0.0 ) + ENDIF + +! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs), +! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv) +! ELSE +! qsmlr(mgs) = 0.0 +! ENDIF +! 10ice version: +! > min( +! > (fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) + +! > fmlt2(mgs)*(qsacr(mgs)+qsacw(mgs)) ) +! < , 0.0 ) + + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + qhmlr(mgs) = & + & meltfac*min( & + & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & + & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) & + & , 0.0 ) + ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + + write(0,*) 'ibinhmlr = 1 not available for 2-moment' + STOP + + ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN + + ENDIF + + + IF ( ivhmltsoak > 0 .and. qhmlr(mgs) < 0.0 .and. lvol(lh) > 1 .and. xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! act as if 100% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*(vx(mgs,lh) + rho0(mgs)*qhmlr(mgs)/xdn(mgs,lh) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhmlr(mgs)/xdnmx(lh) ! volume of melted ice if it were refrozen in the matrix + + vhsoak(mgs) = Min(v1,v2) + + ENDIF + + ENDIF ! qx(mgs,lh) .gt. qxmin(lh) + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( ibinhlmlr == 0 .or. lzhl < 1) THEN + qhlmlr(mgs) = & + & meltfac*min( & + & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & + & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) & + & , 0.0 ) + + ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + +! #ifdef Z3MOM +! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP ) + + ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results + + ENDIF ! ibinhlmlr + + + IF ( ivhmltsoak > 0 .and. qhlmlr(mgs) < 0.0 .and. lvol(lhl) > 1 .and. xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! act as if 50% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*(vx(mgs,lhl) + rho0(mgs)*qhlmlr(mgs)/xdn(mgs,lhl) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhlmlr(mgs)/xdnmx(lhl) ! volume of melted ice if it were refrozen in the matrix + + vhlsoak(mgs) = Min(v1,v2) + + ENDIF + + ENDIF + ENDIF + + ENDIF + +! +! qimlr(mgs) = max( qimlr(mgs), -qimxd(mgs) ) +! qsmlr(mgs) = max( qsmlr(mgs), -qsmxd(mgs) ) +! erm 5/10/2007 changed to next line: + if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)*dtpinv ) ) + IF ( .not. mixedphase ) THEN + qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.95*qx(mgs,lh)*dtpinv ) ) + chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) + ENDIF +! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion + qhmlh(mgs) = 0. + + + ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN + qhlmlr(mgs) = max( qhlmlr(mgs), Min( -qxmxd(mgs,lhl), -0.95*qx(mgs,lhl)*dtpinv ) ) + chlmlr(mgs) = max( chlmlr(mgs), Min( -cxmxd(mgs,lhl), -0.95*cx(mgs,lhl)*dtpinv ) ) + ENDIF + +! + end do + + endif ! } not mixedphase +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs) + IF ( .not. mixedphase ) THEN !{ + IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN +! csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm) + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ELSEIF ( qx(mgs,ls) > qxmin(ls) ) THEN + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ENDIF + + csmlrr(mgs) = csmlr(mgs)/rzxs(mgs) + IF ( -csmlrr(mgs)*dtp > cxmin .and. -qsmlr(mgs)*dtp > qxmin(lr) .and. snowmeltdia > 0.0 ) THEN + rmas = rho0(mgs)*qsmlr(mgs)/csmlrr(mgs) + IF ( rmas > snowmeltmass ) THEN + csmlrr(mgs) = rho0(mgs)*qsmlr(mgs)/snowmeltmass + ENDIF + ENDIF + + + +! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN +! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail +! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) ) +! ELSE + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) + IF ( imltshddmr == 3 .and. qhmlr(mgs) < -qxmin(lh) ) THEN + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! + ! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam + ! chmlr(mgs) = 0.0 + ! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller + + tmp = 1. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lh,1) ) + + x = gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxh(mgs), ratio)/g1palp + + hwvent1 = 0.78*x + y*hwventy(mgs) + + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lh)*hwvent1*xdia(mgs,lh,1), 0.0 ) + + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*(qhmlr(mgs) - qhlmlr1) + + + ENDIF +! IF ( igs(mgs) == 40 ) THEN +! write(0,*) 'is this running? chmlr = ',kgs(mgs), chmlr(mgs) +! ENDIF + ENDIF +! ENDIF + + + + IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0 + + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + IF ( ihmlt .eq. 1 ) THEN + chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN +! chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain +! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas + IF(imltshddmr == 1) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop + tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + + chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) ! old version + chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + ELSE ! Old method + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! into rain + ENDIF + ELSE + chmlrr(mgs) = chmlr(mgs) + ENDIF + ELSEIF ( ihmlt .eq. 0 ) THEN + chmlrr(mgs) = chmlr(mgs) + ENDIF + + ELSE ! ibinhmlr < 0? Already have an outer IF test for ibinhmlr < 1 + chmlrr(mgs) = Min( chmlrr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF + + ENDIF ! } ( chmlr(mgs) < 0.0 .and. ibinhmlr < 1) + + IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN ! { + + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN +! IF ( xdia(mgs,lhl,1) .gt. 1.e-6 .and. Abs(qhlmlr(mgs)) .ge. qxmin(lhl) ) THEN +! chlmlr(mgs) = rho0(mgs)*qhlmlr(mgs)/(pi*xdn(mgs,lhl)*xdia(mgs,lhl,1)**3) ! out of hail +! chlmlr(mgs) = Max( chlmlr(mgs), -cxmxd(mgs,lhl) ) +! ELSE + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlmlr(mgs) + IF ( imltshddmr == 3 .and. qhlmlr(mgs) < -qxmin(lhl) ) THEN +! IF ( .false. .and. imltshddmr == 3 ) THEN +! tmpdiam = (shedalp+alpha(mgs,lhl))*xdia(mgs,lhl,1) +! +! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam +! chlmlr(mgs) = 0.0 +! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller +! + tmp = 1. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lhl,1) ) + + x = gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxhl(mgs), ratio)/g1palp + + hwvent1 = 0.78*x + y*hlventy(mgs) + + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lhl)*hwvent1*xdia(mgs,lhl,1), 0.0 ) + + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*Min(0.0, qhlmlr(mgs) - qhlmlr1) + + ENDIF +! ENDIF + ENDIF + + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN !{ + IF ( ihmlt .eq. 1 ) THEN + chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain +! chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain + IF(imltshddmr == 1 ) THEN + tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam) + chlmlrr(mgs) = -Max(tmp,Min(tmp2,chlmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + ELSE ! old method + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + ENDIF + ELSE + chlmlrr(mgs) = chlmlr(mgs) + ENDIF + ELSEIF ( ihmlt .eq. 0 ) THEN + chlmlrr(mgs) = chlmlr(mgs) + ENDIF + + ELSE ! } { ibinhlmlr > 0 + chlmlrr(mgs) = Min( chlmlrr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF !} + + + ENDIF ! } + + ENDIF ! }.not. mixedphase + +! 10ice versions: +! chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) +! chmlrr(mgs) = chmlr(mgs) + end do + end if + +! +! deposition/sublimation of ice +! + DO mgs = 1,ngscnt + + rwcap(mgs) = (0.5)*xdia(mgs,lr,1) + swcap(mgs) = (0.5)*xdia(mgs,ls,1) + hwcap(mgs) = (0.5)*xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1) + + if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then +! +! from Cotton, 1972 (Part II) +! + cilen(mgs) = 0.4764*(xdia(mgs,li,1))**(0.958) + cval = xdia(mgs,li,1) + aval = cilen(mgs) + eval = Sqrt(1.0-(aval**2)/(cval**2)) + fval = min(0.99,eval) + gval = alog( abs( (1.+fval)/(1.-fval) ) ) + cicap(mgs) = cval*fval / gval + ELSE + cicap(mgs) = 0.0 + end if + ENDDO +! +! + qhldsv(:) = 0.0 + + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + qidsv(mgs) = & + & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac + qsdsv(mgs) = & + & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1), +! : fvds(mgs),civent(mgs),cicap(mgs) +! ENDIF + ELSE + qidsv(mgs) = 0.0 + qsdsv(mgs) = 0.0 + ENDIF + qhdsv(mgs) = & + & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs)*depfac + + IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs)*depfac +! +! + end do +! + + +! #include "nssl.qlimit.F" + +! +! Use a test saturation adjustment to set limits on ice deposition/sublimation +! and rain evaporation +! +! + IF ( DoSublimationFix ) THEN + + do mgs = 1,ngscnt + + qitmp(mgs) = qx(mgs,li) + qx(mgs,ls) + qx(mgs,lh) + IF ( lis > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lis) + IF ( lhl > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lhl) + qrtmp(mgs) = qx(mgs,lr) + qctmp(mgs) = qx(mgs,lc) + qsimxdep(mgs) = 0.0 + qsimxsub(mgs) = 0.0 + dqcitmp(mgs) = 0.0 + + +! IF ( ( qitmp(mgs) > qxmin(li) .or. qrtmp(mgs) > qxmin(lr) ) ) THEN + IF ( qitmp(mgs) > qxmin(li) ) THEN + + qitmp1 = qitmp(mgs) + qctmp1 = qctmp(mgs) + felvcptmp = felvcp(mgs) + felscptmp = felscp(mgs) + qvtmp(mgs) = qx(mgs,lv) + qss(mgs) = qvs(mgs) + qsstmp = qvs(mgs) + qvstmp = qvs(mgs) + qisstmp = qis(mgs) + thetatmp = theta(mgs) + thetaptmp = thetap(mgs) + temgtmp = temg(mgs) + temcgtmp = temcg(mgs) + qvaptmp = qx(mgs,lv) ! qwvp(mgs) + qv0(mgs) + qvptmp = 0.0 ! qwvp(mgs) ! qv pertubation + + qsstmp = qisstmp + + + dqwvtmp(mgs) = ( qvtmp(mgs) - qsstmp ) + + do itertd = 1,2 + +! +! calculate super-saturation +! + IF ( itertd == 1 ) THEN + + ELSE + dqcitmp(mgs) = dqci(mgs) + ! dqwvtmp(mgs) = dqwv(mgs) + ENDIF + + dqcw(mgs) = 0.0 + dqci(mgs) = 0.0 + dqwv(mgs) = ( qvtmp(mgs) - qsstmp ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! { subsaturated + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit + dqci(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all ice available for sublimation + dqci(mgs) = -qitmp(mgs) + dqwv(mgs) = dqwv(mgs) + qitmp(mgs) + end if +! + qvptmp = qvptmp - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor + + IF ( itertd == 2 .and. eqtset > 1 ) THEN + ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content + tmp = qitmp(mgs) !+ qx(mgs,lh) +! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qvtmp(mgs)+cpl*(qx(mgs,lc)+qrtmp(mgs)) & + +cpigb*(tmp) + + felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm + felscptmp = (fels(mgs)-rw*temg(mgs))/cvm + ENDIF + + +! qitmp(mgs) = qx(mgs,li) + qctmp(mgs) = qctmp(mgs) + dqcw(mgs) ! dqcw is zero + qitmp(mgs) = qitmp(mgs) + dqci(mgs) + thetaptmp = thetaptmp + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + + + end if ! } dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN ! { + +! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) +! +! qitmp(mgs) = qx(mgs,li) + fracl(mgs) = 0.0 + fraci(mgs) = 1.0 + if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then +! fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) +! fraci(mgs) = 1.0-fracl(mgs) + end if + if ( temg(mgs) .le. thnuc ) then + fraci(mgs) = 1.0 + fracl(mgs) = 0.0 + end if +! fraci(mgs) = 1.0-fracl(mgs) + + gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & + & / (pi0(mgs)) + + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qsstmp/ & + & ((temg(mgs)-cbi)**2)) + + if ( temg(mgs) .ge. tfr ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qsstmp/ & + & ((temg(mgs)-cbw)**2)) + end if + + delqci1=qx(mgs,li) + + + dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) ! is zero + dqci(mgs) = dqvcnd(mgs)*fraci(mgs) + + thetaptmp = thetaptmp + & + & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & + & / (pi0(mgs)) + + qvptmp = qvptmp - ( dqvcnd(mgs) ) + qctmp(mgs) = qctmp(mgs) + dqcw(mgs) + qitmp(mgs) = qitmp(mgs) + dqci(mgs) + + IF ( itertd == 2 .and. eqtset > 1 ) THEN + ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content + tmp = qitmp(mgs) ! + qx(mgs,lh) +! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qvtmp(mgs)+cpl*(qctmp(mgs) +qrtmp(mgs)) & + +cpigb*(tmp) + + felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm + felscptmp = (fels(mgs)-rw*temg(mgs))/cvm + ENDIF + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (0 & + & +felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + +! +! + END IF ! } dqwv(mgs) .ge. 0. + + +! + IF ( itertd == 1 ) THEN + ! update temporary saturation values + + thetatmp = thetaptmp + theta0(mgs) + temgtmp = thetatmp*pk(mgs) ! ( pres(mgs) / poo ) ** cap + qvaptmp = Max((qvptmp + qv0(mgs)), 0.0) + temcgtmp = temgtmp - tfr + tqvcon = temgtmp-cbw + ltemq = (temgtmp-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvstmp = pqs(mgs)*tabqvs(ltemq) + qisstmp = pqs(mgs)*tabqis(ltemq) + qctmp(mgs) = max( 0.0, qctmp(mgs) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + qvtmp(mgs) = max( 0.0, qvaptmp ) + +! qsstmp = qvstmp + qsstmp = qisstmp + + ELSE + ! set max depletion + qctmp(mgs) = max( 0.0, qctmp(mgs) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + + IF ( qitmp(mgs) < qitmp1 ) THEN + qsimxsub(mgs) = (qitmp1 - qitmp(mgs))*dtpinv + ELSEIF ( qitmp(mgs) > qitmp1 ) THEN + qsimxdep(mgs) = (qitmp(mgs) - qitmp1)*dtpinv + ENDIF + + + ENDIF +! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv +! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qxtmp,qctmp(mgs) +! +! end the saturation adjustment iteration loop +! + end do ! itertd + + ENDIF + + end do ! mgs + + ELSE + + DO mgs = 1,ngscnt + qsimxdep(mgs) = qvimxd(mgs) + qsimxsub(mgs) = 1.e20 + ENDDO + + ENDIF + +! end of qlimit + + do mgs = 1,ngscnt + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN +! qisbv(mgs) = max( min(qidsv(mgs), 0.0), -qimxd(mgs) ) +! qssbv(mgs) = max( min(qsdsv(mgs), 0.0), -qsmxd(mgs) ) +! erm 5/10/2007: + qisbv(mgs) = max( min(qidsv(mgs), 0.0), Min( -qimxd(mgs), -0.5*qx(mgs,li)*dtpinv ) ) + qssbv(mgs) = max( min(qsdsv(mgs), 0.0), Min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) ) + qidpv(mgs) = Max(qidsv(mgs), 0.0) + qsdpv(mgs) = Max(qsdsv(mgs), 0.0) + + + ELSE + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 + ENDIF + + qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) + + + qhdpv(mgs) = Max(qhdsv(mgs), 0.0) + + qhlsbv(mgs) = 0.0 + qhldpv(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) + qhldpv(mgs) = Max(qhldsv(mgs), 0.0) + ENDIF + + temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) + +! IF ( temp1 .gt. qvimxd(mgs) ) THEN + +! frac = qvimxd(mgs)/temp1 + + IF ( temp1 .gt. qsimxdep(mgs) ) THEN + frac = qsimxdep(mgs)/temp1 + + qidpv(mgs) = frac*qidpv(mgs) + qsdpv(mgs) = frac*qsdpv(mgs) + qhdpv(mgs) = frac*qhdpv(mgs) + qhldpv(mgs) = frac*qhldpv(mgs) + +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac +! ENDIF + + ENDIF + + temp1 = qisbv(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) + + + IF ( temp1 < -qsimxsub(mgs) ) THEN + frac = -qsimxsub(mgs)/temp1 + + qisbv(mgs) = frac*qisbv(mgs) + qssbv(mgs) = frac*qssbv(mgs) + qhsbv(mgs) = frac*qhsbv(mgs) + qhlsbv(mgs) = frac*qhlsbv(mgs) + +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac +! ENDIF + + ENDIF + + + end do +! +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cssbv(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qssbv(mgs) + cisbv(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qisbv(mgs) + chsbv(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhsbv(mgs) + IF ( lhl .gt. 1 ) chlsbv(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlsbv(mgs) + csdpv(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsdpv(mgs) + cidpv(mgs) = 0.0 ! (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qidpv(mgs) + cisdpv(mgs) = 0.0 + chdpv(mgs) = 0.0 ! (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhdpv(mgs) + chldpv(mgs) = 0.0 + end do + end if + +! +! Aggregation or size conversion of small crystals to snow +! + if (ndebug .gt. 0 ) write(0,*) 'conc 29a' + do mgs = 1,ngscnt + qscni(mgs) = 0.0 + cscni(mgs) = 0.0 + cscnis(mgs) = 0.0 + if ( ipconc .ge. 4 .and. iscni .ge. 1 .and. qx(mgs,li) .gt. qxmin(li) ) then + IF ( iscni .eq. 1 ) THEN + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + cscnis(mgs) = 0.5*cscni(mgs) + ELSEIF ( iscni .eq. 2 .or. iscni .eq. 4 .or. iscni .eq. 5 ) THEN ! Zeigler 1985/Zrnic 1993, sort of + IF ( iscni .ne. 5 .and. qidpv(mgs) .gt. 0.0 .and. xdia(mgs,li,3) .ge. 100.e-6 ) THEN + ! convert larger crystals to snow +! IF ( xdia(mgs,ls,3) .gt. xdia(mgs,li,3) ) THEN +! qscni(mgs) = Max(0.1,xdia(mgs,li,3)/xdia(mgs,ls,3))*qidpv(mgs) +! erm 9/5/08 changed max to min + qscni(mgs) = Min(0.5, xdia(mgs,li,3)/200.e-6)*qidpv(mgs) +! ELSE +! qscni(mgs) = 0.1*qidpv(mgs) +! ENDIF + cscni(mgs) = fscni*qscni(mgs)*rho0(mgs)/Max(rho_qs*xvmn(ls),xmas(mgs,li)) +! cscni(mgs) = fscni*Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvmn(ls),xmas(mgs,li))) +! cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li) ) +! IF ( xdia(mgs,ls,3) .le. 200.e-6 ) THEN + cscnis(mgs) = cscni(mgs) +! ELSE +! cscnis(mgs) = 0.0 +! ENDIF + ENDIF + + IF ( iscni .ne. 4 ) THEN + ! crystal aggregation to become snow +! erm 9/5/08 commented second line and added xv to 1st line (zrnic et al 1993) + tmp = ess(mgs)*rvt*aa2*cx(mgs,li)*cx(mgs,li)*xv(mgs,li) +! : ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,li)) + +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) + + qscni(mgs) = qscni(mgs) + Min( qxmxd(mgs,li), 2.0*tmp*xmas(mgs,li)*rhoinv(mgs) ) + cscni(mgs) = cscni(mgs) + Min( cxmxd(mgs,li), 2.0*tmp ) + cscnis(mgs) = cscnis(mgs) + Min( cxmxd(mgs,li), tmp ) + ENDIF + ELSEIF ( iscni .eq. 3 ) THEN ! LFO + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + cscni(mgs) = qscni(mgs)*rho0(mgs)/xmas(mgs,li) + cscnis(mgs) = 0.5*cscni(mgs) +! write(iunit,*) 'qscni, qi = ',qscni(mgs),qx(mgs,li),igs(mgs),kgs(mgs) + ENDIF + + ELSEIF ( ipconc < 4 ) THEN ! LFO + IF ( lwsm6 ) THEN + qimax = rhoinv(mgs)*roqimax + qscni(mgs) = Min(0.90*qx(mgs,li), Max( 0.0, (qx(mgs,li) - qimax)*dtpinv ) ) + ELSE + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + ENDIF + else ! 10-ice version + if ( iscni > 0 .and. qx(mgs,li) .gt. qxmin(li) ) then + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + end if + + end if + end do + +! +! +! compute dry growth rate of snow, graupel, and hail +! + do mgs = 1,ngscnt +! + qsdry(mgs) = qsacr(mgs) + qsacw(mgs) & + & + qsaci(mgs) +! + qhdry(mgs) = qhaci(mgs) + qhacs(mgs) & + & + qhacr(mgs) & + & + qhacw(mgs) +! + qhldry(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & + & + qhlacr(mgs) & + & + qhlacw(mgs) + ENDIF + end do +! +! set wet growth and shedding +! + do mgs = 1,ngscnt + + IF ( temg(mgs) < tfr ) THEN +! +! qswet(mgs) = +! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) +! > + fwet2(mgs)*(qsaci(mgs)+qsacir(mgs) +! > +qsacip(mgs)) ) +! qswet(mgs) = max( 0.0, qswet(mgs)) +! +! IF ( dnu(lh) .ne. 0. ) THEN +! qhwet(mgs) = qhdry(mgs) +! ELSE + qhwet(mgs) = & + & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & + & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) + qhwet(mgs) = max( 0.0, qhwet(mgs)) +! ENDIF + + qhlwet(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlwet(mgs) = & + & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) + qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + ENDIF + + ELSE + + qhwet(mgs) = qhdry(mgs) + qhlwet(mgs) = qhldry(mgs) + + ENDIF +! +! qhlwet(mgs) = qhldry(mgs) + + end do +! +! shedding rate +! + qsshr(:) = 0.0 + qhshr(:) = 0.0 + qhlshr(:) = 0.0 + qhshh(:) = 0.0 + csshr(:) = 0.0 + csshrr(:) = 0.0 + chshr(:) = 0.0 + chlshr(:) = 0.0 + chshrr(:) = 0.0 + chlshrr(:) = 0.0 + vhshdr(:) = 0.0 + vhlshdr(:) = 0.0 + wetsfc(:) = .false. + wetgrowth(:) = .false. + wetsfchl(:) = .false. + wetgrowthhl(:) = .false. + + + do mgs = 1,ngscnt +! +! +! + qhshr(mgs) = Min( 0.0, qhwet(mgs) - qhdry(mgs) ) ! water that freezes should never be more than what sheds + + + + qhlshr(mgs) = Min( 0.0, qhlwet(mgs) - qhldry(mgs) ) + +! +! limit wet growth to only higher density particles +! + qsshr(mgs) = 0.0 +! +! +! no shedding for temperatures < 243.15 +! + if ( temg(mgs) .lt. 243.15 ) then + qsshr(mgs) = 0.0 + qhshr(mgs) = 0.0 + qhlshr(mgs) = 0.0 + vhshdr(mgs) = 0.0 + vhlshdr(mgs) = 0.0 + wetsfc(mgs) = .false. + wetgrowth(mgs) = .false. + wetsfchl(mgs) = .false. + wetgrowthhl(mgs) = .false. + end if +! +! shed all at temperatures > 273.15 +! + if ( temg(mgs) .gt. tfr ) then + + IF ( .false. ) THEN ! old and incorrect -- Thanks to Shaofeng Hua for noticing this error (9/17/2017) + qsshr(mgs) = -qsdry(mgs) + qhshr(mgs) = -qhdry(mgs) + qhlshr(mgs) = -qhldry(mgs) + + ELSE ! new and correct + + qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) + qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs) + qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs) + + ENDIF + + vhshdr(mgs) = -vhacw(mgs) - vhacr(mgs) + vhlshdr(mgs) = -vhlacw(mgs) - vhlacr(mgs) + qhwet(mgs) = 0.0 + qhlwet(mgs) = 0.0 + end if +! +! if (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) + wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) +! ENDIF + + if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) + wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) + ENDIF + + end do +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) + ! why is there a number loss for graupel for shedding? NEED TO CHECK THIS + ! chshr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) + ! IF ( temg(mgs) < tfr ) chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding + + chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + + IF ( .false. ) THEN + IF ( temg(mgs) < tfr ) THEN + chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding + ELSE + IF(imltshddmr > 0) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop + tmp = -Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain + tmp2 = -rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) + chshrr(mgs) = -Max(tmp,Min(tmp2,chshrr(mgs))) + ELSE + chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to maximum size allowed for rain or 4.5mm diameter, whichever is smaller +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + ENDIF + ENDIF + ENDIF + + + chlshr(mgs) = 0.0 + chlshrr(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN +! chlshr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) + + + chlshr(mgs) = 0.0 ! no change to hail number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + + + IF ( .false. ) THEN + IF ( temg(mgs) < tfr ) THEN + chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding +! chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vr1mm) ) ! maximum of 1mm drops from shedding + ELSE + IF(imltshddmr > 0) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop + tmp = -Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain + tmp2 = -rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chlshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lhl,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(sheddiam0-sheddiam) + chlshrr(mgs) = -Max(tmp,Min(tmp2,chlshrr(mgs))) + ELSE + chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to 4.5mm diameter or maximum size allowed for rain, whichever is smaller +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + ENDIF + ENDIF + ENDIF + + ENDIF ! ( lhl > 1 ) + + end do + end if + + + +! +! final decisions +! + do mgs = 1,ngscnt +! +! Snow +! + if ( qsshr(mgs) .lt. 0.0 ) then + qsdpv(mgs) = 0.0 + qssbv(mgs) = 0.0 + else + qsshr(mgs) = 0.0 + end if +! +! if ( qsdry(mgs) .lt. qswet(mgs) ) then +! qswet(mgs) = 0.0 +! else +! qsdry(mgs) = 0.0 +! end if +! + +! graupel +! +! + if ( wetgrowth(mgs) .or. (mixedphase .and. fhw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then + + +! soaking (when not advected liquid water film with graupel) + + IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN + ! rescale volumes to maximum density + rimdn(mgs,lh) = xdnmx(lh) + raindn(mgs,lh) = xdnmx(lh) + vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh) + vhacr(mgs) = qhacr(mgs)*rho0(mgs)/raindn(mgs,lh) +! IF ( lvol(lh) .gt. 1 .and. wetgrowth(mgs) ) THEN + IF ( xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! soak some liquid into the graupel +! v1 = xdnmx(lh)*vx(mgs,lh)/(xdn(mgs,lh)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*vx(mgs,lh)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lh)/rho0(mgs))*(xdnmx(lh) - xdn(mgs,lh)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion + + vhsoak(mgs) = Min(v1,v2) + + ENDIF + + vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) + + ELSEIF ( lvol(lh) .gt. 1 .and. mixedphase ) THEN +! vhacw(mgs) = rho0(mgs)*qhacw(mgs)/xdn0(lr) +! vhacr(mgs) = rho0(mgs)*qhacr(mgs)/xdn0(lr) + ENDIF + + + qhdpv(mgs) = 0.0 +! qhsbv(mgs) = 0.0 + chdpv(mgs) = 0.0 +! chsbv(mgs) = 0.0 + +! collection efficiency modification + + IF ( ehi(mgs) .gt. 0.0 ) THEN + qhaci(mgs) = Min(qimxd(mgs),qhaci0(mgs)) ! effectively sets collection eff to 1 + chaci(mgs) = Min(cimxd(mgs),chaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF + IF ( ehs(mgs) .gt. 0.0 ) THEN +! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs)) ! effectively sets collection eff to 1 + qhacs(mgs) = Min(qsmxd(mgs),qhacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + chacs(mgs) = Min(csmxd(mgs),chacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it + qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)) ! plug it back in + ENDIF + +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfc(mgs) = .true. + + else +! qhshr(mgs) = 0.0 + end if +! +! +! hail +! +! if ( lhl .gt. 1 .and. qhlshr(mgs) .lt. 0.0 ) then + if ( lhl > 1 .and. ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) ) then +! if ( wetgrowthhl(mgs) ) then + + + qhldpv(mgs) = 0.0 +! qhlsbv(mgs) = 0.0 + chldpv(mgs) = 0.0 +! chlsbv(mgs) = 0.0 + + + + + IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN +! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN + + rimdn(mgs,lhl) = xdnmx(lhl) + raindn(mgs,lhl) = xdnmx(lhl) + vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) + vhlacr(mgs) = qhlacr(mgs)*rho0(mgs)/raindn(mgs,lhl) + + IF ( xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! soak some liquid into the hail +! v1 = xdnmx(lhl)*vx(mgs,lhl)/(xdn(mgs,lhl)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*vx(mgs,lhl)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lhl)/rho0(mgs))*(xdnmx(lhl) - xdn(mgs,lhl)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) ! volume of frozen accretion + IF ( v1 > v2 ) THEN ! all the frozen stuff fits in + vhlsoak(mgs) = v2 + ELSE ! fill up the available space + vhlsoak(mgs) = v1 + ENDIF +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = Max( 0.0, v2 - v1 ) + ELSE + vhlsoak(mgs) = 0.0 +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl) + + ENDIF + + vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) + + + ELSEIF ( lvol(lhl) .gt. 1 .and. mixedphase ) THEN +! vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/xdn0(lr) +! vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/xdn0(lr) + ENDIF + + IF ( ehli(mgs) .gt. 0.0 ) THEN + qhlaci(mgs) = Min(qimxd(mgs),qhlaci0(mgs)) ! effectively sets collection eff to 1 + chlaci(mgs) = Min(cimxd(mgs),chlaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF + +! IF ( ehls(mgs) .gt. 0.0 ) THEN +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs)) +! ENDIF + IF ( ehls(mgs) .gt. 0.0 ) THEN + qhlacs(mgs) = Min(qsmxd(mgs),qhlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + chlacs(mgs) = Min(csmxd(mgs),chlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + ehls(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)) ! plug it back in + ENDIF + + +! qhlwet(mgs) = 1.0 + +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfchl(mgs) = .true. + + + else +! qhlshr(mgs) = 0.0 +! qhlwet(mgs) = 0.0 + end if + + + end do +! +! Ice -> graupel conversion +! + DO mgs = 1,ngscnt + + qhcni(mgs) = 0.0 + chcni(mgs) = 0.0 + chcnih(mgs) = 0.0 + vhcni(mgs) = 0.0 + + IF ( iglcnvi .ge. 1 ) THEN + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs) - qidpv(mgs) .gt. 0.0 ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + + IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = (qiacw(mgs) - qidpv(mgs)) ! *float(iglcnvi) + chcni(mgs) = cx(mgs,li)*qhcni(mgs)/qx(mgs,li) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + + ELSEIF ( iglcnvi == 3 ) THEN + + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs)*dtp > 2.*qxmin(lh) .and. gamice73fac*xmas(mgs,li) > xdnmn(lh)*xvmn(lh) ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp .ge. xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = 0.5*qiacw(mgs) + chcni(mgs) = qhcni(mgs)/(gamice73fac*xmas(mgs,li)) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + + ENDIF + + + ENDIF + ENDIF + + + ENDDO + + + qhlcnh(:) = 0.0 + chlcnh(:) = 0.0 + chlcnhhl(:) = 0.0 + vhlcnh(:) = 0.0 + vhlcnhl(:) = 0.0 + zhlcnh(:) = 0.0 + + qhcnhl(:) = 0.0 + chcnhl(:) = 0.0 + vhcnhl(:) = 0.0 + zhcnhl(:) = 0.0 + + + IF ( lhl .gt. 1 ) THEN + + IF ( ihlcnh == 1 .or. ihlcnh == 3 ) THEN + +! +! Graupel (h) conversion to hail (hl) based on Milbrandt and Yau 2005b +! + DO mgs = 1,ngscnt + +! IF ( lhl .gt. 1 .and. ipconc .ge. 5 .and. qx(mgs,lh) .gt. 1.0e-3 .and. +! : xdn(mgs,lh) .gt. 750. .and. qhshr(mgs) .lt. 0.0 .and. +! : xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( hlcnhdia > 0 ) THEN + ltest = xdia(mgs,lh,3) .gt. hlcnhdia ! test on mean volume diameter + ELSE +! ltest = xdia(mgs,lh,1)*(3. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on maximum mass diameter + ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter + ENDIF + + dg0(mgs) = -1. + + wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) + + IF ( ihlcnh == 1 ) THEN ! .or. iusedw == 0 THEN + + IF ( ( wetgrowth(mgs) .and. (xdn(mgs,lh) .gt. hldnmn .or. lvh < 1 ) .and. & ! correct this when hail gets turned on + & rimdn(mgs,lh) .gt. 800. .and. & + & ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN ! { +! : xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3 THEN ! 0823.2008 erm test +! IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN ! { + ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05 +! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - +! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0) + IF ( wtest ) THEN + dh0 = dg0(mgs) + ELSE + x = (1.1e4*(rho0(mgs)*qx(mgs,lc)) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0e-3 ) + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dh0 = 0.01*(exp(arg) - 1.0) + ELSE + dh0 = 1.e30 + ENDIF + ENDIF ! wtest +! dh0 = Max( dh0, 5.e-3 ) + +! IF ( dh0 .gt. 0.0 ) write(0,*) 'dh0 = ',dh0 +! IF ( dh0 .gt. 1.0e-4 ) THEN + IF ( xdia(mgs,lh,3)/dh0 .gt. 0.1 ) THEN !{ +! IF ( xdia(mgs,lh,3) .lt. 20.*dh0 .and. dh0 .lt. 2.0*xdia(mgs,lh,3) ) THEN + tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) +! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) + qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) +! IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN +! hdia1 = Max(dh0, xdia(mgs,lh,3) ) +! qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, & +! & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & +! & *exp(-hdia1/xdia(mgs,lh,1)) & +! & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) & +! & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) ) + +! ENDIF + +! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) +! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) + qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) + + IF ( ipconc .ge. 5 ) THEN !{ +! dh0 = Max( xdia(mgs,lh,3), Min( dh0, 5.e-3 ) ) ! do not create hail greater than 5mm diam. unless the graupel is larger + IF ( .not. wtest ) dh0 = Min( dh0, 10.e-3 ) ! do not create hail greater than 10mm diam., which is the max graupel size + IF ( qx(mgs,lhl) > 0.1e-3 ) dh0 = Max( dh0, xdia(mgs,lhl,3) ) ! when enough hail is established, do not dilute the size + chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) ) + + r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter +! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r ) +! chlcnh(mgs) = Min( chlcnh(mgs), r ) + chlcnh(mgs) = Max( chlcnhhl(mgs), r ) + ENDIF !} + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF !} + + ENDIF ! } + ENDIF ! } + + ELSEIF ( ihlcnh == 3 ) THEN !{ + + IF ( wtest .and. & + ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) ) THEN + ! convert number, mass, and reflectivity for d > dw + ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) + + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + + IF ( qxd1 > qxmin(lhl) ) THEN + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + cxd1 = cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN + dh0 = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs) + IF ( dh0 < xmas(mgs,lhl) ) THEN + ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average + dh0 = (( qxd1*dh0**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average + chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 ) + ELSE +! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size + ENDIF + ENDIF + + + + ELSE + qhlcnh(mgs) = 0.0 + ENDIF + +! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN +! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! ENDIF + +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 +! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 +! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 +! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDIF !} + + ENDDO + + ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion + +! +! Staka and Mansell (2005) type conversion -- assuming alphah = 0 for now! +! +! hldia1 is set in micro_module and namelist + IF ( .true. ) THEN + + ! convert number, mass, and reflectivity for d > hldia1, + ! regardless of wet growth status, but as long as riming > 0 + DO mgs = 1,ngscnt + IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN + ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + cxd1 = cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + +! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN +! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! ENDIF + +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 +! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 +! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 +! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDDO + + ELSEIF ( ihlcnh == 0 ) THEN + + do mgs = 1,ngscnt +! qhlcnh(mgs) = 0.0 +! chlcnh(mgs) = 0.0 + if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then + if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then + qhlcnh(mgs) = & + ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & + *exp(-hldia1/xdia(mgs,lh,1)) & + *( (hldia1**3) + 3.0*(hldia1**2)*xdia(mgs,lh,1) & + + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) + qhlcnh(mgs) = min(qhlcnh(mgs),qhmxd(mgs)) + IF ( ipconc .ge. 5 ) THEN + chlcnh(mgs) = Min( cxmxd(mgs,lh), cx(mgs,lh)*Exp(-hldia1/xdia(mgs,lh,1))) + chlcnhhl(mgs) = chlcnh(mgs) +! chlcnh(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(2.0*xmas(mgs,lh) )) + ENDIF + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + end if + end if + end do + + ENDIF ! true + + ENDIF ! ihlcnh options + + ! convert low-density hail to graupel + IF ( icvhl2h >= 1 ) THEN + DO mgs = 1,ngscnt + IF ( qx(mgs,lhl) > qxmin(lhl) .and. xdn(mgs,lhl) < 0.5*(xdnmn(lhl) + xdnmx(lhl)) ) THEN + tmp = Min(0.95, 1. - 0.5*(1. + tanh(0.125*(xdn(mgs,lhl) - 1.01*xdnmn(lhl) )) )) + qhcnhl(mgs) = tmp*qx(mgs,lhl)*dtpinv + chcnhl(mgs) = cx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) + vhcnhl(mgs) = vx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) + + ENDIF + ENDDO + + ENDIF + + + ENDIF ! lhl > 1 + + +! +! Ziegler snow conversion to graupel +! + DO mgs = 1,ngscnt + + qhcns(mgs) = 0.0 + chcns(mgs) = 0.0 + chcnsh(mgs) = 0.0 + vhcns(mgs) = 0.0 + + qscnh(mgs) = 0.0 + cscnh(mgs) = 0.0 + vscnh(mgs) = 0.0 + + IF ( ipconc .ge. 5 ) THEN + + ! test attempt at converting graupel to snow when not riming but growing by deposition + IF ( temg(mgs) < tfr .and. qx(mgs,lh) .gt. qxmin(lh) .and. qhdpv(mgs) > qxmin(lh)*dtpinv & + & .and. qhacw(mgs) < qxmin(lh)*dtpinv ) THEN + IF ( xdn(mgs,lh) < 290. ) THEN +! qscnh(mgs) = 2.*qhdpv(mgs) +! cscnh(mgs) = cx(mgs,lh)*qscnh(mgs)/qx(mgs,lh) +! vscnh(mgs) = rho0(mgs)*qscnh(mgs)/xdn(mgs,lh) + ENDIF + ENDIF + + + IF ( qx(mgs,ls) .gt. qxmin(ls) .and. qsacw(mgs) .gt. 0.0 ) THEN + +! DATA VGRA/1.413E-2/ ! this is the volume (cm**3) of a 3mm diam. sphere +! vgra = 1.4137e-8 m**3 + +! DNNET=DNCNV-DNAGG +! DQNET=QXCON+QSACC+SDEP +! +! DNSCNV=EXP(-(ROS*XNS*VGRA/(RO*QI)))*((1.-(XNS*VGRA*ROS/ +! / (RO*QI)))*DNNET + (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET) +! IF(DNSCNV.LT.0.) DNSCNV=0. +! +! QIHC=(ROS*VGRA/RO)*DNSCNV +! +! QH=QH+DT*QIHC +! QI=QI-DT*QIHC +! XNH=XNH+DT*DNSCNV +! XNS=XNS-DT*DNSCNV + + IF ( iglcnvs .eq. 1 ) THEN ! Zrnic, Ziegler et al (1993) + + dnnet = cscnvis(mgs) + cscnis(mgs) - csacs(mgs) + dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs) + + a3 = 1./(rho0(mgs)*qx(mgs,ls)) + a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) !! EXP(-(ROS*XNS*VGRA/(RO*QI))) +! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET + a2 = (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet +! (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET + a4 = cx(mgs,ls)**2*vgra*xdn(mgs,ls)*a3/qx(mgs,ls)*dqnet + + chcns(mgs) = Max( 0.0, a1*(a2 + a4) ) + chcns(mgs) = Min( chcns(mgs), cxmxd(mgs,ls) ) + chcnsh(mgs) = chcns(mgs) + + qhcns(mgs) = Min( xdn(mgs,ls)*vgra*rhoinv(mgs)*chcns(mgs), qxmxd(mgs,ls) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),xdnmn(lh)) +! vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + + ELSEIF ( iglcnvs .ge. 2 ) THEN ! treat like ice crystals, i.e., check for rime density (ERM) + + IF ( temg(mgs) .lt. 273.0 .and. ( qsacw(mgs) - qsdpv(mgs) .gt. 0.0 .or. & + ( iglcnvs >= 3 .and. qsacw(mgs)*dtp > 2.*qxmin(lh) .and. gamsnow73fac*xmas(mgs,ls) > xdnmn(lh)*xvmn(lh) ) ) ) THEN !{ + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) +! tmp = Min( Max( rimc3, tmp ), 900.0 ) + tmp = Min( tmp , 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + + IF ( iglcnvs == 2 ) THEN !{ + IF ( tmp .ge. 200.0 ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = (qsacw(mgs) - qsdpv(mgs)) + chcns(mgs) = cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF + + ELSEIF ( iglcnvs == 3 ) THEN + + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp > xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = 0.5*qsacw(mgs) + chcns(mgs) = qhcns(mgs)/(gamsnow73fac*xmas(mgs,ls)) + chcns(mgs) = Min( chcns(mgs), cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls)) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF + + ENDIF !} + + ENDIF !} + + ENDIF + + + ENDIF + + ELSE ! single moment lfo + + qhcns(mgs) = 0.001*ehscnv(mgs)*max((qx(mgs,ls)-6.e-4),0.0) + qhcns(mgs) = min(qhcns(mgs),qxmxd(mgs,ls)) + IF ( lvol(lh) .ge. 1 ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + + ENDIF + ENDDO +! +! +! heat budget for rain---not all rain that collects ice can freeze +! +! +! + if ( irwfrz .gt. 0 .and. .not. mixedphase) then +! + do mgs = 1,ngscnt +! +! compute total rain that freeze when it interacts with cloud ice +! + qrztot(mgs) = qrfrz(mgs) + qiacr(mgs) + qsacr(mgs) +! +! compute the maximum amount of rain that can freeze +! Used to limit freezing to 4*qrmxd, but now allow all rain to freeze if possible +! + qrzmax(mgs) = & + & ( xdia(mgs,lr,1)*rwvent(mgs)*cx(mgs,lr)*fwet1(mgs) ) + qrzmax(mgs) = max(qrzmax(mgs), 0.0) + qrzmax(mgs) = min(qrztot(mgs), qrzmax(mgs)) + qrzmax(mgs) = min(qx(mgs,lr)*dtpinv, qrzmax(mgs)) + + IF ( temcg(mgs) < -30. ) THEN ! allow all to freeze if T < -30 because fwet becomes invalid (negative) + qrzmax(mgs) = qx(mgs,lr)*dtpinv + ENDIF +! qrzmax(mgs) = min(4.*qrmxd(mgs), qrzmax(mgs)) +! +! compute the correction factor +! +! IF ( qrztot(mgs) .gt. qxmin(lr) ) THEN + IF ( qrztot(mgs) .gt. qrzmax(mgs) .and. qrztot(mgs) .gt. qxmin(lr) ) THEN + qrzfac(mgs) = qrzmax(mgs)/(qrztot(mgs)) + ELSE + qrzfac(mgs) = 1.0 + ENDIF + qrzfac(mgs) = min(1.0, qrzfac(mgs)) +! + end do +! +! +! now correct the above sources +! +! + do mgs = 1,ngscnt + if ( temg(mgs) .le. 273.15 .and. qrzfac(mgs) .lt. 1.0 ) then + qrfrz(mgs) = qrzfac(mgs)*qrfrz(mgs) + qrfrzs(mgs) = qrzfac(mgs)*qrfrzs(mgs) + qrfrzf(mgs) = qrzfac(mgs)*qrfrzf(mgs) + qiacr(mgs) = qrzfac(mgs)*qiacr(mgs) + qsacr(mgs) = qrzfac(mgs)*qsacr(mgs) + qiacrf(mgs) = qrzfac(mgs)*qiacrf(mgs) + qiacrs(mgs) = qrzfac(mgs)*qiacrs(mgs) + crfrz(mgs) = qrzfac(mgs)*crfrz(mgs) + crfrzf(mgs) = qrzfac(mgs)*crfrzf(mgs) + crfrzs(mgs) = qrzfac(mgs)*crfrzs(mgs) + ciacr(mgs) = qrzfac(mgs)*ciacr(mgs) + ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) + ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) + + + vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) + viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) + end if + end do +! +! +! + end if +! +! +! +! evaporation of rain +! +! +! + qrcev(:) = 0.0 + crcev(:) = 0.0 + + + do mgs = 1,ngscnt +! + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + qrcev(mgs) = & + & fvce(mgs)*cx(mgs,lr)*rwvent(mgs)*rwcap(mgs)*evapfac +! this line to allow condensation on rain: + IF ( rcond .eq. 1 ) THEN + qrcev(mgs) = min(qrcev(mgs), qxmxd(mgs,lv)) +! this line to have evaporation only: + ELSE + qrcev(mgs) = min(qrcev(mgs), 0.0) + ENDIF + + qrcev(mgs) = max(qrcev(mgs), -qrmxd(mgs)) +! if ( temg(mgs) .lt. 273.15 ) qrcev(mgs) = 0.0 + IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN +! qrcev(mgs) = -qrmxd(mgs) +! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs) + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + ELSE + crcev(mgs) = 0.0 + ENDIF +! if ( temg(mgs) .lt. 273.15 ) crcev(mgs) = 0.0 +! + ENDIF + + end do +! +! evaporation/condensation of wet graupel and snow +! + qscev(:) = 0.0 + cscev(:) = 0.0 + qhcev(:) = 0.0 + chcev(:) = 0.0 + qhlcev(:) = 0.0 + chlcev(:) = 0.0 + + IF ( lhwlg > 1 ) THEN + qhcevlg(:) = 0.0 + chcevlg(:) = 0.0 + ENDIF + IF ( lhlwlg > 1 ) THEN + qhlcevlg(:) = 0.0 + chlcevlg(:) = 0.0 + ENDIF + +! +! +! +! ICE MULTIPLICATION: Two modes (rimpa, and rimpb) +! (following Cotton et al. 1986) +! + + chmul1(:) = 0.0 + chlmul1(:) = 0.0 + csmul1(:) = 0.0 +! + qhmul1(:) = 0.0 + qhlmul1(:) = 0.0 + qsmul1(:) = 0.0 + + do mgs = 1,ngscnt + + ltest = qx(mgs,lh) .gt. qxmin(lh) + IF ( lhl > 1 ) ltest = ltest .or. qx(mgs,lhl) .gt. qxmin(lhl) + + IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 ) & + & .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then + IF ( ipconc .ge. 2 ) THEN + IF ( xv(mgs,lc) .gt. 0.0 & + & .and. ltest & +! .and. itype2 .ge. 2 & + & ) THEN +! +! Ziegler et al. 1986 Hallett-Mossop process. VSTAR = 7.23e-15 (vol of 12micron radius) +! + IF ( alpha(mgs,lc) == 0.0 ) THEN + ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc)) + ELSE + + ratio = (1. + alpha(mgs,lc))*(7.23e-15)/xv(mgs,lc) + + IF ( usegamxinfcnu ) THEN + i = Nint(dgami*(1. + alpha(mgs,lc))) + gcnup1 = gmoi(i) + ex1 = (1./250.)*Gamxinf(1.+alpha(mgs,lc), ratio)/(gcnup1) + ELSE + ratio = Min( maxratiolu, ratio ) + tmp = gaminterp(ratio,alpha(mgs,lc),1,1) + ex1 = (1./250.)*tmp + ENDIF + ENDIF + IF ( itype2 .le. 2 ) THEN + ft = Max(0.0,Min(1.0,-0.11*temcg(mgs)**2 - 1.1*temcg(mgs)-1.7)) + ELSE + IF ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) THEN + ft = 0.5 + ELSEIF (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) THEN + ft = 1.0 + ELSEIF (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) THEN + ft = 0.5 + ELSE + ft = 0.0 + ENDIF + ENDIF +! rhoinv = 1./rho0(mgs) +! DNSTAR = ex1*cglacw(mgs) + + IF ( ft > 0.0 ) THEN + + IF ( itype2 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + chmul1(mgs) = ft*ex1*chacw(mgs) +! chmul1(mgs) = Min( ft*ex1*chacw(mgs), ft*(30.*1.e+06)*rho0(mgs)*qhacw(mgs) ) ! 1.e+6 converts kg to mg; Saunders & Hosseini (2001) average of about 30 crystals per mg + qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs) + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + chlmul1(mgs) = (ft*ex1*chlacw(mgs)) + qhlmul1(mgs) = cimas0*chlmul1(mgs)*rhoinv(mgs) + ENDIF + ENDIF + ENDIF ! itype2 + + IF ( itype1 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhacw(mgs) + chmul1(mgs) = chmul1(mgs) + tmp + qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs) + chlmul1(mgs) = chlmul1(mgs) + tmp + qhlmul1(mgs) = qhlmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF + ENDIF + ENDIF ! itype1 + + + ENDIF ! ft + + ENDIF ! xv(mgs,lc) .gt. 0.0 .and. + + ELSE ! ipconc .lt. 2 +! +! define the temperature function +! + fimt1(mgs) = 0.0 +! +! Cotton et al. (1986) version +! + if ( temg(mgs) .ge. 268.15 .and. temg(mgs) .le. 270.15 ) then + fimt1(mgs) = 1.0 -(temg(mgs)-268.15)/2.0 + elseif (temg(mgs) .le. 268.15 .and. temg(mgs) .ge. 265.15 ) then + fimt1(mgs) = 1.0 +(temg(mgs)-268.15)/3.0 + ELSE + fimt1(mgs) = 0.0 + end if +! +! Ferrier (1994) version +! + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) then + fimt1(mgs) = 0.5 + elseif (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) then + fimt1(mgs) = 1.0 + elseif (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) then + fimt1(mgs) = 0.5 + ELSE + fimt1(mgs) = 0.0 + end if +! +! +! type I: 350 splinters are formed for every 1e-3 grams of cloud +! water accreted by graupel/hail (note converted to MKS units) +! 3.5e+8 has units of 1/kg +! + IF ( itype1 .ge. 1 ) THEN + fimta(mgs) = (3.5e+08)*rho0(mgs) + ELSE + fimta(mgs) = 0.0 + ENDIF + +! +! +! type II: 1 splinter formed for every 250 cloud droplets larger than +! 24 micons in diameter (12 microns in radius) accreted by +! graupel/hail +! +! + fimt2(mgs) = 0.0 + xcwmas = xmas(mgs,lc) * 1000. +! + IF ( itype2 .ge. 1 ) THEN + if ( xcwmas.lt.1.26e-9 ) then + fimt2(mgs) = 0.0 + end if + if ( xcwmas .le. 3.55e-9 .and. xcwmas .ge. 1.26e-9 ) then + fimt2(mgs) = (2.27)*alog(xcwmas) + 13.39 + end if + if ( xcwmas .gt. 3.55e-9 ) then + fimt2(mgs) = 1.0 + end if + + fimt2(mgs) = min(fimt2(mgs),1.0) + fimt2(mgs) = max(fimt2(mgs),0.0) + + ENDIF +! +! qhmul2 = 0.0 +! qsmul2 = 0.0 +! +! qhmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qhacw(mgs) +! qsmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qsacw(mgs) +! +! cimas0 = (1.0e-12) +! cimas0 = 2.5e-10 + IF ( .not. wetsfc(mgs) ) THEN + chmul1(mgs) = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhacw(mgs) + ENDIF +! + qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) + + + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhlacw(mgs) + chlmul1(mgs) = tmp + qhlmul1(mgs) = cimas0*tmp*rhoinv(mgs) + ENDIF + ENDIF + +! qsmul1(mgs) = csmul1(mgs)*(cimas0/rho0(mgs)) +! + ENDIF ! ( ipconc .ge. 2 ) + + end if ! (in temperature range) + + ENDIF ! ( itype1 .eq. 1 .or. itype2 .eq. 1) +! + end do +! +! +! +! end if +! +! end do +! +! +! ICE MULTIPLICATION FROM SNOW +! Lo and Passarelli 82 / Willis and Heymsfield 89 / Schuur and Rutledge 00b +! using kfrag as fragmentation rate (s-1) / 500 microns as char mean diam for max snow mix ratio +! + csmul(:) = 0.0 + qsmul(:) = 0.0 + + IF ( isnwfrac /= 0 ) THEN + do mgs = 1,ngscnt + IF (temg(mgs) .gt. 265.0) THEN !{ + if (xdia(mgs,ls,1) .gt. 100.e-6 .and. xdia(mgs,ls,1) .lt. 2.0e-3) then ! equiv diameter 100microns to 2mm + + tmp = rhoinv(mgs)*pi*xdn(mgs,ls)*cx(mgs,ls)*(500.e-6)**3 + qsmul(mgs) = Max( kfrag*( qx(mgs,ls) - tmp ) , 0.0 ) + + qsmul(mgs) = Min( qxmxd(mgs,li), qsmul(mgs) ) + csmul(mgs) = Min( cxmxd(mgs,li), rho0(mgs)*qsmul(mgs)/mfrag ) + + endif + ENDIF !} + enddo + ENDIF + +! +! frozen rain-rain interaction.... +! +! +! +! +! rain-ice interaction +! +! + do mgs = 1,ngscnt + qracif(mgs) = qraci(mgs) + cracif(mgs) = craci(mgs) +! ciacrf(mgs) = ciacr(mgs) + end do +! +! +! vapor to pristine ice crystals UP +! +! +! +! compute the nucleation rate +! +! do mgs = 1,ngscnt +! idqis = 0 +! if ( ssi(mgs) .gt. 1.0 ) idqis = 1 +! fiinit(mgs) = (felv(mgs)**2)/(cp*rw) +! dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ +! > (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) +! cnnt = min(cnit*exp(-temcg(mgs)*bta1),1.0e+09) +! qiint(mgs) = +! > il5(mgs)*idqis*(1.0*dtpinv) +! < *min((6.88e-13)*cnnt/rho0(mgs), 0.25*dqisdt(mgs)) +! end do +! +! Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation +! + cmassin = cimasn ! 6.88e-13 + do mgs = 1,ngscnt + qiint(mgs) = 0.0 + ciint(mgs) = 0.0 + qicicnt(mgs) = 0.0 + cicint(mgs) = 0.0 + qipipnt(mgs) = 0.0 + cipint(mgs) = 0.0 + ccitmp = 0.0 + IF ( icenucopt == 1 .or. icenucopt == -10 .or. icenucopt == -11 ) THEN + if ( ( temg(mgs) .lt. 268.15 .or. & +! : ( imeyers5 .and. temg(mgs) .lt. 273.0) ) .and. & + & ( imeyers5 .and. temg(mgs) .lt. 272.0 .and. temgkm2(mgs) .lt. tfr) ) .and. & + & ciintmx .gt. (cx(mgs,li)+ccitmp) & +! : .and. cninm(mgs) .gt. 0. & + & ) then + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ & + & (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) + idqis = 0 + if ( ssi(mgs) .gt. 1.0 ) THEN + idqis = 1 + dzfacp = max( float(kgsp(mgs)-kgs(mgs)), 0.0 ) + dzfacm = max( float(kgs(mgs)-kgsm(mgs)), 0.0 ) + qiint(mgs) = & + & idqis*il5(mgs) & + & *(cmassin/rho0(mgs)) & + & *max(0.0,wvel(mgs)) & + & *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs)) & + & /((dzfacp+dzfacm)) + + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + +! +! limit new crystals so it does not increase the current concentration +! above ciintmx 20,000 per liter (2.e7 per m**3) +! +! ciintmx = 1.e9 +! ciintmx = 1.e9 + IF ( icenucopt /= -10 ) THEN + + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(ciint(mgs), ccin(mgs)*dtpinv) ! because ciint is a *rate* + ccin(mgs) = ccin(mgs) - ciint(mgs)*dtp + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ELSEIF ( lcina > 1 ) THEN + ciint(mgs) = Max(0.0, Min( ciint(mgs), Min( cnina(mgs), ciintmx ) - cina(mgs) )) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( icenucopt == 1 .and. ciint(mgs) .gt. Max(0.0, ciintmx - cx(mgs,li) - ccitmp )*dtpinv ) THEN + ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) )*dtpinv + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( icenucopt == -11 .and. dtp*ciint(mgs) .gt. ( cnina(mgs) - (cx(mgs,li) - ccitmp))) THEN + ciint(mgs) = Max(0.0, cnina(mgs) - (cx(mgs,li)+ccitmp)*dtpinv ) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ENDIF + ENDIF + + end if + endif + + ELSEIF ( icenucopt == 2 .or. icenucopt == -1 .or. icenucopt == -2 ) THEN + + IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 1.0 ) .or. ssi(mgs) > 1.25 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) - ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx + ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/(1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + ENDIF + + + + ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 10 ) THEN + IF ( temg(mgs) .lt. 268.15 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) + ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx + ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ENDIF + + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qipipnt(mgs) = qiint(mgs) + cipint(mgs) = ciint(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qicicnt(mgs) = qiint(mgs) + cicint(mgs) = ciint(mgs) + end if +! +! qipipnt(mgs) = 0.0 +! qicicnt(mgs) = qiint(mgs) +! + end do +! +! + +! +! vapor to cloud droplets UP +! + if (ndebug .gt. 0 ) write(0,*) 'dbg = 8' +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: set 3-component' +! +! time for riming.... +! +! rimtim = 240.0 +! dtrim = rimtim +! xacrtim = 120.0 +! tranfr = 0.50 +! tranfw = 0.50 +! +! coefficients for riming +! +! rimc1 = 300.00 +! rimc2 = 0.44 +! +! +! zero som arrays +! +! + do mgs = 1,ngscnt + qrshr(mgs) = 0.0 + qsshrp(mgs) = 0.0 + qhshrp(mgs) = 0.0 + end do +! +! +! first sum all of the shed rain +! +! + do mgs = 1,ngscnt + qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) + crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) + IF ( ipconc .ge. 3 ) THEN +! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) ) + ENDIF + end do +! +! +! + +! +! +! +! + IF ( ipconc .ge. 1 ) THEN +! +! +! concentration production terms +! +! YYY +! +! +! DO mgs = 1,ngscnt + pccwi(:) = 0.0 + pccwd(:) = 0.0 + pccwdacc(:) = 0.0 + pccii(:) = 0.0 + pccin(:) = 0.0 + pccid(:) = 0.0 + pcisi(:) = 0.0 + pcisd(:) = 0.0 + pcrwi(:) = 0.0 + pcrwd(:) = 0.0 + pcswi(:) = 0.0 + pcswd(:) = 0.0 + pchwi(:) = 0.0 + pchwd(:) = 0.0 + pchli(:) = 0.0 + pchld(:) = 0.0 +! ENDDO +! +! Cloud ice +! +! IF ( ipconc .ge. 1 ) THEN + + IF ( warmonly < 0.5 ) THEN + IF ( ffrzs < 1.0 ) THEN + do mgs = 1,ngscnt + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) + + pccii(mgs) = pccii(mgs)*(1.0 - ffrzs) + +! > + nsplinter*(crfrzf(mgs) + crfrz(mgs)) + pccid(mgs) = & + & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & + & -craci(mgs) & + & -csaci(mgs) & + & -chaci(mgs) - chlaci(mgs) & + & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + + + end do + ENDIF ! ffrzs + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + +! qiint(mgs) = 0.0 +! cicint(mgs) = 0.0 +! qicicnt(mgs) = 0.0 + + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) + + pccii(mgs) = pccii(mgs)*(1. - ffrzs) + pccid(mgs) = & +! & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & +! & -craci(mgs) & +! & -csaci(mgs) & +! & -chaci(mgs) - chlaci(mgs) & +! & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + + end do + ENDIF ! warmonly + + +! ENDIF ! ( ipconc .ge. 1 ) +! +! Cloud water +! + IF ( ipconc .ge. 2 ) THEN + + do mgs = 1,ngscnt + pccwi(mgs) = (0.0) ! + (1-il5(mgs))*(-cirmlw(mgs)) + + IF ( warmonly < 0.5 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*(-ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + + ELSEIF ( warmonly < 0.8 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*( & + & -ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & + & ) & + & -cracw(mgs) -chacw(mgs) -chlacw(mgs) + ELSE + +! tmp3d(igs(mgs),jy,kgs(mgs)) = crcnw(mgs) + +! cracw(mgs) = 0.0 ! turn off accretion +! qracw(mgs) = 0.0 +! crcev(mgs) = 0.0 ! turn off evap +! qrcev(mgs) = 0.0 ! turn off evap +! cracr(mgs) = 0.0 ! turn off self collection + + +! cautn(mgs) = 0.0 +! crcnw(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + pccwd(mgs) = & + & - cautn(mgs) -cracw(mgs) + ENDIF + + + IF ( .false. .and. exwmindiam > 0.0 .and. ccwresv(mgs) > 0.0 ) THEN + pccwdacc(mgs) = & + & il5(mgs)*(-ciacw(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + IF ( -pccwdacc(mgs)*dtp .gt. cx(mgs,lc) - ccwresv(mgs) ) THEN + + frac = -(cx(mgs,lc) - ccwresv(mgs) )/(pccwdacc(mgs)*dtp) + pccwdacc(mgs) = -(cx(mgs,lc) - ccwresv(mgs) )*dtpinv + + ciacw(mgs) = frac*ciacw(mgs) + cracw(mgs) = frac*cracw(mgs) + csacw(mgs) = frac*csacw(mgs) + chacw(mgs) = frac*chacw(mgs) + cautn(mgs) = frac*cautn(mgs) + + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + +! resum + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & + & -cwfrzc(mgs)-cwctfzc(mgs) & + & -il5(mgs)*(ciihr(mgs)) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + ENDIF + + ENDIF + + + IF ( -pccwd(mgs)*dtp .gt. cx(mgs,lc) ) THEN +! write(0,*) 'OUCH! pccwd(mgs)*dtp .gt. ccw(mgs) ',pccwd(mgs),cx(mgs,lc) +! write(0,*) 'qc = ',qx(mgs,lc) +! write(0,*) -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs)-cwfrzc(mgs)-cwctfzc(mgs) +! write(0,*) -cracw(mgs) -csacw(mgs) -chacw(mgs) +! write(0,*) - cautn(mgs) + + frac = -cx(mgs,lc)/(pccwd(mgs)*dtp) + pccwd(mgs) = -cx(mgs,lc)*dtpinv + + ciacw(mgs) = frac*ciacw(mgs) + cwfrz(mgs) = frac*cwfrz(mgs) + cwfrzp(mgs) = frac*cwfrzp(mgs) + cwctfzp(mgs) = frac*cwctfzp(mgs) + cwfrzc(mgs) = frac*cwfrzc(mgs) + cwctfzc(mgs) = frac*cwctfzc(mgs) + cwctfz(mgs) = frac*cwctfz(mgs) + cracw(mgs) = frac*cracw(mgs) + csacw(mgs) = frac*csacw(mgs) + chacw(mgs) = frac*chacw(mgs) + cautn(mgs) = frac*cautn(mgs) + + pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs) + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + +! STOP + ENDIF + + end do + + ENDIF ! ipconc + +! +! Rain +! + IF ( ipconc .ge. 3 ) THEN + + do mgs = 1,ngscnt + + IF ( warmonly < 0.5 ) THEN + pcrwi(mgs) = & +! > cracw(mgs) + & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & +! & -csmlr(mgs)/rzxs(mgs) & + & -csmlrr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs)) +! > -csacr(mgs) & + & - chacr(mgs) - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) +! > -il5(mgs)*ciracr(mgs) + ELSEIF ( warmonly < 0.8 ) THEN + pcrwi(mgs) = & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & +! & -csmlr(mgs) & + & -csmlrr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*( - crfrz(mgs) ) & ! - cipacr(mgs)) + & - chacr(mgs) & + & - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) + ELSE + pcrwi(mgs) = & + & crcnw(mgs) + pcrwd(mgs) = & + & +crcev(mgs) & + & - cracr(mgs) + +! tmp3d(igs(mgs),jy,kgs(mgs)) = vtxbar(mgs,lr,1) ! crcnw(mgs) ! (pcrwi(mgs) + pcrwd(mgs)) +! pcrwi(mgs) = 0.0 +! pcrwd(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + ENDIF + + + frac = 0.0 + IF ( -pcrwd(mgs)*dtp .gt. cx(mgs,lr) ) THEN +! write(0,*) 'OUCH! pcrwd(mgs)*dtp .gt. crw(mgs) ',pcrwd(mgs)*dtp,cx(mgs,lr),mgs,igs(mgs),kgs(mgs) +! write(0,*) -ciacr(mgs) +! write(0,*) -crfrz(mgs) +! write(0,*) -chacr(mgs) +! write(0,*) crcev(mgs) +! write(0,*) -cracr(mgs) + + frac = -cx(mgs,lr)/(pcrwd(mgs)*dtp) + pcrwd(mgs) = -cx(mgs,lr)*dtpinv + + ciacr(mgs) = frac*ciacr(mgs) + ciacrf(mgs) = frac*ciacrf(mgs) + ciacrs(mgs) = frac*ciacrs(mgs) + crfrz(mgs) = frac*crfrz(mgs) + crfrzf(mgs) = frac*crfrzf(mgs) + crfrzs(mgs) = frac*crfrzs(mgs) + chacr(mgs) = frac*chacr(mgs) + chlacr(mgs) = frac*chlacr(mgs) + crcev(mgs) = frac*crcev(mgs) + cracr(mgs) = frac*cracr(mgs) + +! STOP + ENDIF + + end do + + ENDIF + + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + IF ( ipconc .ge. 4 ) THEN ! + + do mgs = 1,ngscnt + pcswi(mgs) = & + & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & + & + cwfrz2snowfrac*cwfrz(mgs)/cwfrz2snowratio & + & + cscnh(mgs) + + IF ( ffrzs > 0.0 ) THEN + pcswi(mgs) = pcswi(mgs) + ffrzs* ( & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) ) + ENDIF + + + IF ( ess0 < 0.0 ) THEN + csacs(mgs) = Max(0.0, csacs(mgs) - (ifrzs)*(crfrzs(mgs) + ciacrs(mgs))) + ENDIF + + pcswd(mgs) = & +! : cracs(mgs) & + & -chacs(mgs) - chlacs(mgs) & + & -chcns(mgs) & + & +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & ! + csshrp(mgs) +! > +il5(mgs)*(cssbv(mgs)) & + & + cssbv(mgs) & + & - csacs(mgs) + + frac = 0.0 + IF ( imixedphase == 0 ) THEN + IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN + frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp) + + pqswd(mgs) = frac*pqswd(mgs) + + chacs(mgs) = frac*chacs(mgs) + chlacs(mgs) = frac*chlacs(mgs) + chcns(mgs) = frac*chcns(mgs) + csmlr(mgs) = frac*csmlr(mgs) + csshr(mgs) = frac*csshr(mgs) + cssbv(mgs) = frac*cssbv(mgs) + csacs(mgs) = frac*csacs(mgs) + + ENDIF + ENDIF + + + + pccii(mgs) = pccii(mgs) & + & + (1. - ifrzs)*crfrzs(mgs) & + & + (1. - ifrzs)*ciacrs(mgs) + + pcswi(mgs) = pcswi(mgs) & + & + (ifrzs)*crfrzs(mgs) & + & + (ifrzs)*ciacrs(mgs) + + end do + + ENDIF + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +(ifrzg*crfrzf(mgs) & + & +il5(mgs)*ifiacrg*(ciacrf(mgs) )) & + & + chcnsh(mgs) + chcnih(mgs) + chcnhl(mgs) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & +! > + il5(mgs)*chsbv(mgs) & + & + chsbv(mgs) & + & - il5(mgs)*chlcnh(mgs) & + & - cscnh(mgs) + end do +! + +! +! Hail +! + IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = ((1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*(1.0-ifiacrg)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhlh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) & +! > + il5(mgs)*chlsbv(mgs) & + & + chlsbv(mgs) - chcnhl(mgs) + + IF ( imixedphase == 0 ) THEN + frac = 0.0 + IF ( cx(mgs,lhl) + dtp*(pchli(mgs) + pchld(mgs)) < 0.0 ) THEN + ! rescale depletion + + frac = (-cx(mgs,lhl) + pchli(mgs)*dtp)/(pchld(mgs)*dtp) + + chlmlr(mgs) = frac*chlmlr(mgs) + chlsbv(mgs) = frac*chlsbv(mgs) + chcnhl(mgs) = frac*chcnhl(mgs) + + pchld(mgs) = frac*pchld(mgs) + + ENDIF + ENDIF + end do + + ENDIF +! + + ENDIF ! (ipconc .ge. 5 ) + + ELSEIF ( warmonly < 0.8 ) THEN + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +ifrzg*(crfrzf(mgs) ) ! +il5(mgs)*(ciacrf(mgs) )) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & + & - il5(mgs)*chlcnh(mgs) + end do +! +! Hail +! + IF ( lhl .gt. 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs)) & ! +il5(mgs)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhl(mgs)/rzxh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) ! & +! > + il5(mgs)*chlsbv(mgs) & +! & + chlsbv(mgs) + +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF + end do + + ENDIF + + ENDIF ! ipconc >= 5 + + ENDIF ! warmonly + +! + +! +! Balance and checks for continuity.....within machine precision... +! + do mgs = 1,ngscnt + pctot(mgs) = pccwi(mgs) +pccwd(mgs) + & + & pccii(mgs) +pccid(mgs) + & + & pcrwi(mgs) +pcrwd(mgs) + & + & pcswi(mgs) +pcswd(mgs) + & + & pchwi(mgs) +pchwd(mgs) + & + & pchli(mgs) +pchld(mgs) + end do +! +! + ENDIF ! ( ipconc .ge. 1 ) +! +! +! +! +! +! GOGO +! production terms for mass +! +! + pqwvi(:) = 0.0 + pqwvd(:) = 0.0 + pqcwi(:) = 0.0 + pqcwd(:) = 0.0 + pqcwdacc(:) = 0.0 + pqcii(:) = 0.0 + pqcid(:) = 0.0 + pqrwi(:) = 0.0 + pqrwd(:) = 0.0 + pqswi(:) = 0.0 + pqswd(:) = 0.0 + pqhwi(:) = 0.0 + pqhwd(:) = 0.0 + pqhli(:) = 0.0 + pqhld(:) = 0.0 + pqlwsi(:) = 0.0 + pqlwsd(:) = 0.0 + pqlwhi(:) = 0.0 + pqlwhd(:) = 0.0 + pqlwlghi(:) = 0.0 + pqlwlghd(:) = 0.0 + pqlwlghli(:) = 0.0 + pqlwlghld(:) = 0.0 + pqlwhli(:) = 0.0 + pqlwhld(:) = 0.0 +! +! Vapor +! + IF ( warmonly < 0.5 ) THEN + do mgs = 1,ngscnt + +! NOTE: ANY CHANGES HERE ALSO NEED TO GO INTO THE RESUM FARTHER DOWN! + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + + end do + + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -il5(mgs)*qisbv(mgs) + pqwvd(mgs) = & + & +il5(mgs)*(-qiint(mgs) & +! & -qhdpv(mgs) ) & !- qhldpv(mgs)) & + & -qhdpv(mgs) - qhldpv(mgs)) & +! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -Max(0.0, qrcev(mgs)) & + & -il5(mgs)*qidpv(mgs) + end do + + ELSE + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) + end do + + ENDIF ! warmonly +! +! Cloud water +! + do mgs = 1,ngscnt + + pqcwi(mgs) = (0.0) + qwcnr(mgs) + + IF ( warmonly < 0.5 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & + & -il5(mgs)*(qiihr(mgs)) & + & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) !& +! & -il5(mgs)*(qwfrzp(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & + & -il5(mgs)*(qiihr(mgs)) & + & -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs) + ELSE + pqcwd(mgs) = & + & -qracw(mgs) - qrcnw(mgs) + ENDIF + + + IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN + + frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp) + pqcwd(mgs) = -qx(mgs,lc)*dtpinv + + qiacw(mgs) = frac*qiacw(mgs) +! qwfrzp(mgs) = frac*qwfrzp(mgs) +! qwctfzp(mgs) = frac*qwctfzp(mgs) + qwfrzc(mgs) = frac*qwfrzc(mgs) + qwfrzis(mgs) = frac*qwfrzis(mgs) + qwfrz(mgs) = frac*qwfrz(mgs) + qwctfzc(mgs) = frac*qwctfzc(mgs) + qwctfzis(mgs) = frac*qwctfzis(mgs) + qwctfz(mgs) = frac*qwctfz(mgs) + qracw(mgs) = frac*qracw(mgs) + qsacw(mgs) = frac*qsacw(mgs) + qhacw(mgs) = frac*qhacw(mgs) + vhacw(mgs) = frac*vhacw(mgs) + qrcnw(mgs) = frac*qrcnw(mgs) + qwfrzp(mgs) = frac*qwfrzp(mgs) + IF ( lhl .gt. 1 ) THEN + qhlacw(mgs) = frac*qhlacw(mgs) + vhlacw(mgs) = frac*vhlacw(mgs) + ENDIF +! IF ( lzh .gt. 1 ) zhacw(mgs) = frac*zhacw(mgs) + +! STOP + ENDIF + + + end do +! +! Cloud ice +! + IF ( warmonly < 0.5 ) THEN + + do mgs = 1,ngscnt + IF ( ffrzs < 1.0 ) THEN + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs)) & + & +il5(mgs)*(qicichr(mgs)) & + & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) +! > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + ENDIF + + pqcii(mgs) = pqcii(mgs)*(1.0 - ffrzs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) + + pqcid(mgs) = & + & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & + & -qraci(mgs) & + & -qsaci(mgs) ) & + & -qhaci(mgs) & + & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) & + & - qhcni(mgs) + end do + + + ELSEIF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs)*(1. - ffrzs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs))*(1. - ffrzs) & + & +il5(mgs)*(qicichr(mgs))*(1. - ffrzs) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) ! & ! (qiacwi(mgs)+qwacii(mgs)) & +! & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & +! & +qhmul1(mgs) + qhlmul1(mgs) & +! & + qsplinter(mgs) + qsplinter2(mgs) + + pqcid(mgs) = & +! & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & +! & -qraci(mgs) & +! & -qsaci(mgs) ) & +! & -qhaci(mgs) & +! & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) ! & +! & - qhcni(mgs) + end do + + ENDIF +! +! Rain +! + + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhmlr(mgs) & !null at this point when wet snow/graupel included + & -qsmlr(mgs) - qhlmlr(mgs) & + & -qimlr(mgs)) & + & -qsshr(mgs) & !null at this point when wet snow/graupel included + & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & + & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhmlr(mgs) & !null at this point when wet snow/graupel included + & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlmlr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) ) !null at this point when wet snow/graupel included + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + + + ! IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + + frac = (-qx(mgs,lr) + pqrwi(mgs)*dtp)/(pqrwd(mgs)*dtp) +! pqrwd(mgs) = -qx(mgs,lr)*dtpinv + pqrwi(mgs) + + pqwvi(mgs) = pqwvi(mgs) & + & + Min(0.0, qrcev(mgs)) & + & - frac*Min(0.0, qrcev(mgs)) + pqwvd(mgs) = pqwvd(mgs) & + & + Max(0.0, qrcev(mgs)) & + & - frac*Max(0.0, qrcev(mgs)) + + qiacr(mgs) = frac*qiacr(mgs) + qiacrf(mgs) = frac*qiacrf(mgs) + qiacrs(mgs) = frac*qiacrs(mgs) + viacrf(mgs) = frac*viacrf(mgs) + qrfrz(mgs) = frac*qrfrz(mgs) + qrfrzs(mgs) = frac*qrfrzs(mgs) + qrfrzf(mgs) = frac*qrfrzf(mgs) + vrfrzf(mgs) = frac*vrfrzf(mgs) + qsacr(mgs) = frac*qsacr(mgs) + qhacr(mgs) = frac*qhacr(mgs) + vhacr(mgs) = frac*vhacr(mgs) + qrcev(mgs) = frac*qrcev(mgs) + qhlacr(mgs) = frac*qhlacr(mgs) + vhlacr(mgs) = frac*vhlacr(mgs) +! qhcev(mgs) = frac*qhcev(mgs) + + + IF ( warmonly < 0.5 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs)) & + & - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + +! +! Resum for vapor since qrcev has changed +! + IF ( qrcev(mgs) .ne. 0.0 ) THEN + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + + ENDIF + + +! STOP + ENDIF + end do + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + do mgs = 1,ngscnt + pqswi(mgs) = & + & il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) & + & + ifrzs*(qiacrs(mgs) + qrfrzs(mgs)) & + & + il5(mgs)*(( qwfrzc(mgs) + qwctfzc(mgs) + qicichr(mgs) )*ffrzs & + & + (1.0 - ffrzs)*cwfrz2snowfrac*qwfrz(mgs) ) & + & + il2(mgs)*qsacr(mgs)) & + & + il5(mgs)*qicicnt(mgs)*ffrzs & + & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & ! only applies for ipconc <= 3 + & + Max(0.0, qscev(mgs)) & + & + qsacw(mgs) + qscnh(mgs) & + & + ffrzs*(qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs)) + pqswd(mgs) = & +! > -qfacs(mgs) ! -qwacs(mgs) & + & -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs) & + & -qhcns(mgs) & + & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included +! > +il5(mgs)*(qssbv(mgs)) & + & + (qssbv(mgs)) & + & + Min(0.0, qscev(mgs)) & + & -qsmul(mgs) + + + IF ( imixedphase == 0 .and. pqswd(mgs) .lt. 0.0 ) THEN + IF ( qx(mgs,ls) + dtp*(pqswi(mgs) + pqswd(mgs)) < 0.0 ) THEN + frac = (-qx(mgs,ls) + pqswi(mgs)*dtp)/(pqswd(mgs)*dtp) + + pqswd(mgs) = frac*pqswd(mgs) + + qracs(mgs) = frac*qracs(mgs) ! only used for single moment at this time + qhacs(mgs) = frac*qhacs(mgs) + qhlacs(mgs) = frac*qhlacs(mgs) + qhcns(mgs) = frac*qhcns(mgs) + qsmlr(mgs) = frac*qsmlr(mgs) + qsshr(mgs) = frac*qsshr(mgs) + qssbv(mgs) = frac*qssbv(mgs) + qsmul(mgs) = frac*qsmul(mgs) + IF ( qscev(mgs) < 0.0 ) qscev(mgs) = frac*qscev(mgs) + + ENDIF + ENDIF + + pqcii(mgs) = pqcii(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & + (1. - ifrzs)*qiacrs(mgs) + + end do + +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*(ifrzg*qrfrzf(mgs) + (1-il3(mgs))*(ifiacrg)*(qiacrf(mgs)+qracif(mgs))) & + & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & + & +il5(mgs)*(qhdpv(mgs)) & + & +Max(0.0, qhcev(mgs)) & + & +qhacr(mgs)+qhacw(mgs) & + & +qhacs(mgs)+qhaci(mgs) & + & + qhcns(mgs) + qhcni(mgs) + qhcnhl(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & +(1-il5(mgs))*qhmlr(mgs) & !null at this point when wet graupel included +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) - qhlcnh(mgs) - qscnh(mgs) & + & - qsplinter(mgs) - qsplinter2(mgs) +! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + end do + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) + ((1.0-ifrzg)*qrfrzf(mgs) + (1.0-ifiacrg)*(qiacrf(mgs)+ qracif(mgs)))) & + & +Max(0.0, qhlcev(mgs)) & + & +qhlacr(mgs)+qhlacw(mgs) & + & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + IF ( imixedphase == 0 ) THEN + frac = 0.0 + IF ( qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs)) < 0.0 ) THEN + ! rescale depletion + + frac = (-qx(mgs,lhl) + pqhli(mgs)*dtp)/(pqhld(mgs)*dtp) + + qhlmlr(mgs) = frac*qhlmlr(mgs) + qhlsbv(mgs) = frac*qhlsbv(mgs) + qhcnhl(mgs) = frac*qhcnhl(mgs) + qhlmul1(mgs) = frac*qhlmul1(mgs) + IF ( qhlcev(mgs) < 0.0 ) qhlcev(mgs) = frac*qhlcev(mgs) + + pqhld(mgs) = frac*pqhld(mgs) + + ENDIF + ENDIF + + + end do + + ENDIF ! lhl + + ELSEIF ( warmonly < 0.8 ) THEN +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) & + & +il5(mgs)*(qhdpv(mgs)) & + & +qhacr(mgs)+qhacw(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & - qhlcnh(mgs) & + & - qhmul1(mgs) & + & - qsplinter(mgs) - qsplinter2(mgs) & + & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included + end do + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & + & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & + & +qhlacr(mgs)+qhlacw(mgs) & +! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + end do + + ENDIF ! lhl + + ENDIF ! warmonly + +! +! Liquid water on snow and graupel +! + + vhmlr(:) = 0.0 + vhlmlr(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel + +! vhshdr(:) = 0.0 + vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation +! vhsoak(:) = 0.0 + +! vhlshdr(:) = 0.0 + vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation +! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) +! vhlsoak(:) = 0.0 + + ENDIF ! mixedphase + + + +! +! Snow volume +! + IF ( lvol(ls) .gt. 1 ) THEN + do mgs = 1,ngscnt +! pvswi(mgs) = rho0(mgs)*( pqswi(mgs) )/xdn0(ls) + + pvswi(mgs) = rho0(mgs)*( & +!aps > il5*qsfzs(mgs)/xdn(mgs,ls) & +!aps > -il5*qsfzs(mgs)/xdn(mgs,lr) & + & +il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) + (1. - ifrzs)*qiacrs(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & )/xdn0(ls) & + & + (qsacr(mgs))/rimdn(mgs,ls) ) + vsacw(mgs) +! > + (qsacw(mgs) + qsacr(mgs))/rimdn(mgs,ls) ) + pvswd(mgs) = rho0(mgs)*( pqswd(mgs) )/xdn0(ls) & +! > -qhacs(mgs) +! > -qhcns(mgs) +! > +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) +! > +il5(mgs)*(qssbv(mgs)) + & -rho0(mgs)*qsmul(mgs)/xdn0(ls) +!aps > +rho0(mgs)*(1-il5(mgs))*( +!aps > qsmlr(mgs)/xdn(mgs,ls) +!aps > +(qscev-qsmlr(mgs))/xdn(mgs,lr) ) + end do + +!aps IF (mixedphase) THEN +!aps pvswd(mgs) = pvswd(mgs) +!aps > + rho0(mgs)*qsshr(mgs)/xdn(mgs,lr) +!aps ENDIF + + ENDIF +! +! Graupel volume +! + IF ( lvol(lh) .gt. 1 ) THEN + DO mgs = 1,ngscnt +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) )/xdn0(lh) ) + +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) - il5(mgs)*qrfrzf(mgs) )/xdn0(lh) ! +! : + il5(mgs)*qrfrzf(mgs)/rhofrz ) + + pvhwi(mgs) = rho0(mgs)*( & + & +il5(mgs)*( ifiacrg*qracif(mgs))/rhofrz & +!erm > + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)? & + & + ( il5(mgs)*qhdpv(mgs)/qhdpvdn & + & + (qhacs(mgs) + qhaci(mgs))/qhacidn ) ) & + & + rho0(mgs)*Max(0.0, qhcev(mgs))/1000. & ! only used in mixed phase: evaporation/condensation of liquid water coating +! > + qhacs(mgs) + qhaci(mgs) )/xdn0(ls) ) & + & + vhcns(mgs) & + & + vhacr(mgs) + vhacw(mgs) + vhfzh(mgs) & ! qhacw(mgs)/rimdn(mgs,lh) +! > + vhfrh(mgs) & + & + vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs)) +! > +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh) + +! pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh) + + pvhwd(mgs) = rho0(mgs)*( & +! > qhshr(mgs)/xdn0(lr) & +! > - il5(mgs)*qhfzh(mgs)/xdn(mgs,lr) & + & +( (1-il5(mgs))*vhmlr(mgs) & +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) )/xdn(mgs,lh) ) & + & - vhlcnh(mgs) + vhshdr(mgs) - vhsoak(mgs) - vscnh(mgs) + +! IF (mixedphase) THEN +! pvhwd(mgs) = pvhwd(mgs) +! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) +! ENDIF + + IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN + + write(iunit,*) + write(iunit,*) 'Graupel at ',igs(mgs),kgs(mgs) +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) 'qhcns',qhcns(mgs) + write(iunit,*) 'qhcni',qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) 'qhacr ',qhacr(mgs) + write(iunit,*) 'qhacw', qhacw(mgs) + write(iunit,*) 'qhacs', qhacs(mgs) + write(iunit,*) 'qhaci', qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) 'qhcev',qhcev(mgs) + write(iunit,*) + write(iunit,*) 'qhshr',qhshr(mgs) + write(iunit,*) 'qhmlr', (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) 'qhsbv', qhsbv(mgs) + write(iunit,*) 'qhlcnh',-qhlcnh(mgs) + write(iunit,*) 'qhmul1',-qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) + write(iunit,*) 'Volume' + write(iunit,*) + write(iunit,*) 'pvhwi',pvhwi(mgs) + write(iunit,*) 'vhcns', vhcns(mgs) + write(iunit,*) 'vhacr,vhacw',vhacr(mgs), vhacw(mgs) ! qhacw(mgs)/rimdn(mgs,lh) + write(iunit,*) 'vhcni',vhcni(mgs) + write(iunit,*) + write(iunit,*) 'pvhwd',pvhwd(mgs) + write(iunit,*) 'vhlcnh,vhshdr,vhsoak ', vhlcnh(mgs), vhshdr(mgs), vhsoak(mgs) + write(iunit,*) 'vhmlr', vhmlr(mgs) + write(iunit,*) +! write(iunit,*) +! write(iunit,*) +! write(iunit,*) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + + + ENDIF + + + ENDDO + + ENDIF +! +! +! + +! +! Hail volume +! + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + DO mgs = 1,ngscnt + + pvhli(mgs) = rho0(mgs)*( & + & + ( il5(mgs)*(((1.0-ifiacrg)*qracif(mgs))/rhofrz + qhldpv(mgs) ) & +! & + Max(0.0, qhlcev(mgs)) & +! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) ) & ! xdn0(ls) ) & +! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose + & + qhlacs(mgs) + qhlaci(mgs) )/500. ) & ! changed to 500 instead of min graupel density to keep hail density from dropping too much + & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & + & + vhlcnhl(mgs) + ((1.0-ifiacrg)*viacrf(mgs) + (1.0-ifrzg)*vrfrzf(mgs)) & + & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl) + + pvhld(mgs) = rho0(mgs)*( & + & +( qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) )/xdn(mgs,lhl) ) & +! & + vhlmlr(mgs) & + & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & + & + vhlshdr(mgs) - vhlsoak(mgs) + + + ENDDO + + ENDIF + ENDIF + + + if ( ndebug .ge. 1 ) then + do mgs = 1,ngscnt +! + ptotal(mgs) = 0. + ptotal(mgs) = ptotal(mgs) & + & + pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) +! + + + ENDDO + + do mgs = 1,ngscnt + + if ( ( (ndebug .ge. 0 ) .and. abs(ptotal(mgs)) .gt. eqtot ) & +! if ( ( abs(ptotal(mgs)) .gt. eqtot ) +! : .or. pqswi(mgs)*dtp .gt. 1.e-3 +! : .or. pqhwi(mgs)*dtp .gt. 1.e-3 +! : .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3 +! : .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7 +! : .or. dtp*(pcipi(mgs)+pcipd(mgs)) .gt. 1.e7 & + & .or. .not. (ptotal(mgs) .lt. 1.0 .and. ptotal(mgs) .gt. -1.0) & ! this line is basically checking for NaNs + & ) then + write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs, & + & kgs(mgs),ptotal(mgs) + + write(iunit,*) 't7: ', t7(igs(mgs),jgs,kgs(mgs)) + write(iunit,*) 'cci,ccw,crw,rdia: ',cx(mgs,li),cx(mgs,lc),cx(mgs,lr),0.5*xdia(mgs,lr,1) + write(iunit,*) 'qc,qi,qr : ',qx(mgs,lc),qx(mgs,li),qx(mgs,lr) + write(iunit,*) 'rmas, qrcalc : ',xmas(mgs,lr),xmas(mgs,lr)*cx(mgs,lr)/rho0(mgs) + write(iunit,*) 'vti,vtc,eiw,vtr: ',vtxbar(mgs,li,1),vtxbar(mgs,lc,1),eiw(mgs),vtxbar(mgs,lr,1) + write(iunit,*) 'cidia,cwdia,qcmxd: ', xdia(mgs,li,1),xdia(mgs,lc,1),qcmxd(mgs) + write(iunit,*) 'snow: ',qx(mgs,ls),cx(mgs,ls),swvent(mgs),vtxbar(mgs,ls,1),xdia(mgs,ls,1) + write(iunit,*) 'graupel: ',qx(mgs,lh),cx(mgs,lh),hwvent(mgs),vtxbar(mgs,lh,1),xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) write(iunit,*) 'hail: ',qx(mgs,lhl),cx(mgs,lhl),hlvent(mgs),vtxbar(mgs,lhl,1),xdia(mgs,lhl,1) + + + write(iunit,*) 'li: ',xdia(mgs,li,1),xdia(mgs,li,2),xmas(mgs,li),qx(mgs,li), & + & vtxbar(mgs,li,1) + + + write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr) + write(iunit,*) 'temcg = ', temcg(mgs) + + write(iunit,*) 'v ', pqwvi(mgs) ,pqwvd(mgs) + write(iunit,*) 'c ', pqcwi(mgs) ,pqcwd(mgs) + write(iunit,*) 'ci', pqcii(mgs) ,pqcid(mgs) + write(iunit,*) 'r ', pqrwi(mgs) ,pqrwd(mgs) + write(iunit,*) 's ', pqswi(mgs) ,pqswd(mgs) + write(iunit,*) 'h ', pqhwi(mgs) ,pqhwd(mgs) + write(iunit,*) 'hl', pqhli(mgs) ,pqhld(mgs) + tmp = pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) + + write(iunit,*) 'total = ',tmp + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + +! +! print production terms +! + write(iunit,*) + write(iunit,*) 'Vapor' +! + write(iunit,*) -Min(0.0,qrcev(mgs)) + write(iunit,*) -il5(mgs)*qhsbv(mgs) + write(iunit,*) -il5(mgs)*qhlsbv(mgs) + write(iunit,*) -il5(mgs)*qssbv(mgs) + write(iunit,*) -il5(mgs)*qisbv(mgs) + write(iunit,*) 'pqwvi= ', pqwvi(mgs) + write(iunit,*) -Max(0.0,qrcev(mgs)) + write(iunit,*) -Max(0.0,qhcev(mgs)) + write(iunit,*) -Max(0.0,qhlcev(mgs)) + write(iunit,*) -Max(0.0,qscev(mgs)) + write(iunit,*) -il5(mgs)*qiint(mgs) + write(iunit,*) -il5(mgs)*qhdpv(mgs) + write(iunit,*) -il5(mgs)*qhldpv(mgs) + write(iunit,*) -il5(mgs)*qsdpv(mgs) + write(iunit,*) -il5(mgs)*qidpv(mgs) + write(iunit,*) 'pqwvd = ', pqwvd(mgs) +! + write(iunit,*) + write(iunit,*) 'Cloud ice' +! + write(iunit,*) il5(mgs)*qicicnt(mgs) + write(iunit,*) il5(mgs)*qidpv(mgs) + write(iunit,*) il5(mgs)*qiacw(mgs) + write(iunit,*) il5(mgs)*qwfrzc(mgs) + write(iunit,*) il5(mgs)*qwctfzc(mgs) + write(iunit,*) il5(mgs)*qicichr(mgs) + write(iunit,*) qhmul1(mgs) + write(iunit,*) qhlmul1(mgs) + write(iunit,*) 'pqcii = ', pqcii(mgs) + write(iunit,*) -il5(mgs)*qscni(mgs) + write(iunit,*) -il5(mgs)*qscnvi(mgs) + write(iunit,*) -il5(mgs)*qraci(mgs) + write(iunit,*) -il5(mgs)*qsaci(mgs) + write(iunit,*) -il5(mgs)*qhaci(mgs) + write(iunit,*) -il5(mgs)*qhlaci(mgs) + write(iunit,*) il5(mgs)*qisbv(mgs) + write(iunit,*) (1.-il5(mgs))*qimlr(mgs) + write(iunit,*) -il5(mgs)*qhcni(mgs) + write(iunit,*) 'pqcid = ', pqcid(mgs) + write(iunit,*) ' Conc:' + write(iunit,*) pccii(mgs),pccid(mgs) + write(iunit,*) il5(mgs),cicint(mgs) + write(iunit,*) cwacii(mgs),cwfrzc(mgs),cwctfzc(mgs) + write(iunit,*) cicichr(mgs) + write(iunit,*) chmul1(mgs) + write(iunit,*) chlmul1(mgs) + write(iunit,*) csmul(mgs) +! +! +! +! + write(iunit,*) + write(iunit,*) 'Cloud water' +! + write(iunit,*) 'pqcwi =', pqcwi(mgs) + write(iunit,*) -il5(mgs)*qiacw(mgs) + write(iunit,*) -il5(mgs)*qwfrzc(mgs) + write(iunit,*) -il5(mgs)*qwctfzc(mgs) + write(iunit,*) -il5(mgs)*qwctfzis(mgs) +! write(iunit,*) -il5(mgs)*qwfrzp(mgs) +! write(iunit,*) -il5(mgs)*qwctfzp(mgs) + write(iunit,*) -il5(mgs)*qiihr(mgs) + write(iunit,*) -il5(mgs)*qicichr(mgs) + write(iunit,*) -il5(mgs)*qipiphr(mgs) + write(iunit,*) -qracw(mgs) + write(iunit,*) -qsacw(mgs) + write(iunit,*) -qrcnw(mgs) + write(iunit,*) -qhacw(mgs) + write(iunit,*) -qhlacw(mgs) + write(iunit,*) 'pqcwd = ', pqcwd(mgs) + + + write(iunit,*) + write(iunit,*) 'Concentration:' + write(iunit,*) -cautn(mgs) + write(iunit,*) -cracw(mgs) + write(iunit,*) -csacw(mgs) + write(iunit,*) -chacw(mgs) + write(iunit,*) -ciacw(mgs) + write(iunit,*) -cwfrzp(mgs) + write(iunit,*) -cwctfzp(mgs) + write(iunit,*) -cwfrzc(mgs) + write(iunit,*) -cwctfzc(mgs) + write(iunit,*) pccwd(mgs) +! + write(iunit,*) + write(iunit,*) 'Rain ' +! + write(iunit,*) qracw(mgs) + write(iunit,*) qrcnw(mgs) + write(iunit,*) Max(0.0, qrcev(mgs)) + write(iunit,*) -(1-il5(mgs))*qhmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qsmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qimlr(mgs) + write(iunit,*) -qrshr(mgs) + write(iunit,*) 'pqrwi = ', pqrwi(mgs) + write(iunit,*) -qsshr(mgs) + write(iunit,*) -qhshr(mgs) + write(iunit,*) -qhlshr(mgs) + write(iunit,*) -il5(mgs)*qiacr(mgs),qiacr(mgs), qiacrf(mgs) + write(iunit,*) -il5(mgs)*qrfrz(mgs) + write(iunit,*) -qsacr(mgs) + write(iunit,*) -qhacr(mgs) + write(iunit,*) -qhlacr(mgs) + write(iunit,*) qrcev(mgs) + write(iunit,*) 'pqrwd = ', pqrwd(mgs) + write(iunit,*) 'fhw, fhlw = ',fhw(mgs),fhlw(mgs) + write(iunit,*) 'qrzfac = ', qrzfac(mgs) +! + + write(iunit,*) + write(iunit,*) 'Rain concentration' + write(iunit,*) pcrwi(mgs) + write(iunit,*) crcnw(mgs) + write(iunit,*) 1-il5(mgs) + write(iunit,*) -chmlr(mgs),-csmlr(mgs) + write(iunit,*) -crshr(mgs) + write(iunit,*) pcrwd(mgs) + write(iunit,*) il5(mgs) + write(iunit,*) -ciacr(mgs),-crfrz(mgs) + write(iunit,*) -csacr(mgs),-chacr(mgs) + write(iunit,*) +crcev(mgs) + write(iunit,*) cracr(mgs) +! write(iunit,*) -il5(mgs)*ciracr(mgs) + + + write(iunit,*) + write(iunit,*) 'Snow' +! + write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs) + write(iunit,*) il5(mgs)*qsaci(mgs) + write(iunit,*) il5(mgs)*qrfrzs(mgs) + write(iunit,*) il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs) + write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs) + write(iunit,*) qsacw(mgs) + write(iunit,*) qsacr(mgs), qscnh(mgs) + write(iunit,*) 'pqswi = ',pqswi(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) -qracs(mgs) + write(iunit,*) -qhacs(mgs) + write(iunit,*) -qhlacs(mgs) + write(iunit,*) (1-il5(mgs))*qsmlr(mgs) + write(iunit,*) qsshr(mgs) +! write(iunit,*) qsshrp(mgs) + write(iunit,*) il5(mgs)*(qssbv(mgs)) + write(iunit,*) 'pqswd = ', pqswd(mgs) + write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) + write(iunit,*) (qssbv(mgs)) + write(iunit,*) Min(0.0, qscev(mgs)) + write(iunit,*) -qsmul(mgs) +! +! + write(iunit,*) + write(iunit,*) 'Graupel' +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) qhcns(mgs) + write(iunit,*) qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) qhacr(mgs) + write(iunit,*) qhacw(mgs) + write(iunit,*) qhacs(mgs) + write(iunit,*) qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) qhshr(mgs) + write(iunit,*) (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) il5(mgs),qhsbv(mgs) + write(iunit,*) -qhlcnh(mgs) + write(iunit,*) -qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + +! + write(iunit,*) + write(iunit,*) 'Hail' +! + write(iunit,*) qhlcnh(mgs) + write(iunit,*) il5(mgs)*(qhldpv(mgs)) + write(iunit,*) qhlacr(mgs) + write(iunit,*) qhlacw(mgs) + write(iunit,*) qhlacs(mgs) + write(iunit,*) qhlaci(mgs) + write(iunit,*) pqhli(mgs) + write(iunit,*) + write(iunit,*) qhlshr(mgs) + write(iunit,*) (1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) il5(mgs)*qhlsbv(mgs) + write(iunit,*) pqhld(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchli(mgs),pchld(mgs) + write(iunit,*) chlcnh(mgs) +! +! Balance and checks for continuity.....within machine precision... +! +! + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + write(iunit,*) 'PTOTAL',ptotal(mgs) +! + end if ! ptotal out of bounds or NaN +! + end do +! + + end if ! ( nstep/12*12 .eq. nstep ) + +! +! latent heating from phase changes (except qcw, qci cond, and evap) +! + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*(1-imixedphase)*( & + & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & + & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & + & +qsshr(mgs) & + & +qhshr(mgs) & + & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) & + & ) & + & +il5(mgs)*(qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs)) + pmlt(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) + ! NOTE: psub is sum of sublimation and deposition + psub(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + pevap(mgs) = & + & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) + ! NOTE: pdep is the deposition part only + pdep(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*( & + & +qhshr(mgs) & + & +qhlshr(mgs) & + & +qrfrz(mgs)+qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs) & + & +qhacw(mgs) + qhlacw(mgs) & + & +qhacr(mgs) + qhlacr(mgs) ) + psub(mgs) = 0.0 + & + & il5(mgs)*( & + & + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) + ELSE + pfrz(mgs) = 0.0 + psub(mgs) = 0.0 + pvap(mgs) = qrcev(mgs) + ENDIF ! warmonly + ptem(mgs) = & + & (1./pi0(mgs))* & + & (felfcp(mgs)*pfrz(mgs) & + & +felscp(mgs)*psub(mgs) & + & +felvcp(mgs)*pvap(mgs)) + thetap(mgs) = thetap(mgs) + dtp*ptem(mgs) + ptem2(mgs) = ptem(mgs) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (felfpi(mgs)*pfrz(mgs) & + & +felspi(mgs)*psub(mgs) & + & +felvpi(mgs)*pvap(mgs))*dtp + ENDIF + end do + + + + +! +! sum the sources and sinks for qwvp, qcw, qci, qrw, qsw +! +! + do mgs = 1,ngscnt + qwvp(mgs) = qwvp(mgs) + & + & dtp*(pqwvi(mgs)+pqwvd(mgs)) + qx(mgs,lc) = qx(mgs,lc) + & + & dtp*(pqcwi(mgs)+pqcwd(mgs)) + qx(mgs,lr) = qx(mgs,lr) + & + & dtp*(pqrwi(mgs)+pqrwd(mgs)) + qx(mgs,li) = qx(mgs,li) + & + & dtp*(pqcii(mgs)+pqcid(mgs)) + qx(mgs,ls) = qx(mgs,ls) + & + & dtp*(pqswi(mgs)+pqswd(mgs)) + qx(mgs,lh) = qx(mgs,lh) + & + & dtp*(pqhwi(mgs)+pqhwd(mgs)) + IF ( lhl .gt. 1 ) THEN + qx(mgs,lhl) = qx(mgs,lhl) + & + & dtp*(pqhli(mgs)+pqhld(mgs)) + ENDIF + + + end do + +! sum sources for particle volume + + IF ( ldovol ) THEN + + do mgs = 1,ngscnt + + IF ( lvol(ls) .gt. 1 ) THEN + vx(mgs,ls) = vx(mgs,ls) + & + & dtp*(pvswi(mgs)+pvswd(mgs)) + ENDIF + + IF ( lvol(lh) .gt. 1 ) THEN + vx(mgs,lh) = vx(mgs,lh) + & + & dtp*(pvhwi(mgs)+pvhwd(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + vx(mgs,lhl) = vx(mgs,lhl) + & + & dtp*(pvhli(mgs)+pvhld(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + ENDIF + + ENDDO + + ENDIF ! ldovol + +! +! +! +! concentrations +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = cx(mgs,li) + & + & dtp*(pccii(mgs)+pccid(mgs)) + cina(mgs) = cina(mgs) + pccin(mgs)*dtp + IF ( ipconc .ge. 2 ) THEN + cx(mgs,lc) = cx(mgs,lc) + & + & dtp*(pccwi(mgs)+pccwd(mgs)) + ENDIF + IF ( ipconc .ge. 3 ) THEN + cx(mgs,lr) = cx(mgs,lr) + & + & dtp*(pcrwi(mgs)+pcrwd(mgs)) + ENDIF + IF ( ipconc .ge. 4 ) THEN + cx(mgs,ls) = cx(mgs,ls) + & + & dtp*(pcswi(mgs)+pcswd(mgs)) + ENDIF + IF ( ipconc .ge. 5 ) THEN + cx(mgs,lh) = cx(mgs,lh) + & + & dtp*(pchwi(mgs)+pchwd(mgs)) + IF ( lhl .gt. 1 ) THEN + cx(mgs,lhl) = cx(mgs,lhl) + & + & dtp*(pchli(mgs)+pchld(mgs)) + + + ENDIF + ENDIF + end do + end if + + + IF ( wrfchem_flag > 0 ) THEN + DO mgs = 1,ngscnt + evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) + rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + & + qraci(mgs) + qsaci(mgs) + qhaci(mgs) + qhlaci(mgs) + qscni(mgs) + ENDDO + ENDIF +! +! +! +! start saturation adjustment +! + if (ndebug .gt. 0 ) write(0,*) 'conc 30a' +! include 'sam.jms.satadj.sgi' +! +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + do mgs = 1,ngscnt + pqs(mgs) = (380.0)/(pres(mgs)) + theta(mgs) = thetap(mgs) + theta0(mgs) + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + end do +! +! melting of cloud ice +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptimlw(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + if( temg(mgs) .gt. tfr .and. & + & qitmp(mgs) .gt. 0.0 ) then + qx(mgs,lc) = qx(mgs,lc) + qitmp(mgs) +! pfrz(mgs) = pfrz(mgs) - qitmp(mgs)*dtpinv + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(- qitmp(mgs)*dtpinv) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) - (felfpi(mgs)*qitmp(mgs)) + ENDIF + pmlt(mgs) = pmlt(mgs) - qitmp(mgs)*dtpinv + scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li) + thetap(mgs) = thetap(mgs) - & + & fcc3(mgs)*qitmp(mgs) + ptimlw(mgs) = -fcc3(mgs)*qitmp(mgs)*dtpinv + cx(mgs,lc) = cx(mgs,lc) + cx(mgs,li) + qx(mgs,li) = 0.0 + cx(mgs,li) = 0.0 + scx(mgs,li) = 0.0 + vx(mgs,li) = 0.0 + qitmp(mgs) = 0.0 + end if + end do + +! +! + + +! do mgs = 1,ngscnt +! qimlw(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv +! end do +! +! homogeneous freezing of cloud water +! + IF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptwfzi(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + +! if( temg(mgs) .lt. tfrh ) THEN +! write(0,*) 'GS: mgs,temp,qc,qi = ',mgs,temg(mgs),temcg(mgs),qx(mgs,lc),qx(mgs,li) +! ENDIF + + ctmp = 0.0 + frac = 0.0 + qtmp = 0.0 + +! if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and. & +! & qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then +! commented for test (12/01/2015): +! if( temg(mgs) .lt. thnuc + 0. .and. & +! & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then + if( ( ( temg(mgs) .lt. thnuc + 0.) .or. (temg(mgs) .lt. thnuc + 2. .and. ibfc >= 3) ) .and. & + & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2)) then + + IF ( ibfc >= 3 ) THEN + frac = Max( 0.25, Min( 1., ((thnuc + 2.) - temg(mgs) )/4.0 ) ) + ELSEIF ( ibfc /= 2 .or. ipconc < 2 ) THEN + frac = Max( 0.25, Min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) ) + ELSE + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 + + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc)) ! number of droplets with volume greater than volt + + qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes + ! sure that cwfrz and qwfrz are consistent and prevents + ! spurious creation of ice crystals. + + ENDIF + qtmp = frac*qx(mgs,lc) + + IF ( ibfc == 4 .and. lis >= 1 ) THEN + qx(mgs,lis) = qx(mgs,lis) + qtmp + ELSE + qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc) + ENDIF + pfrz(mgs) = pfrz(mgs) + qtmp*dtpinv + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(qtmp*dtpinv) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felfpi(mgs)*qtmp + ENDIF + +! IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qx(mgs,lc)/xdn0(li) + IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li) + + IF ( ipconc .ge. 2 ) THEN + ctmp = frac*cx(mgs,lc) +! cx(mgs,li) = cx(mgs,li) + cx(mgs,lc) + IF ( ibfc == 4 .and. lis >= 1 ) THEN + cx(mgs,lis) = cx(mgs,lis) + ctmp + ELSE + cx(mgs,li) = cx(mgs,li) + ctmp + ENDIF + ELSE ! (ipconc .lt. 2 ) + ctmp = 0.0 + IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN + qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1) + +! cx(mgs,lc) = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ELSE + cx(mgs,lc) = Max(0.0,wvel(mgs))*dtp*cwccn & + & /gz(igs(mgs),jgs,kgs(mgs)) + cx(mgs,lc) = cwccn + ENDIF + + IF ( ipconc .ge. 1 ) cx(mgs,li) = Min(ccimx, cx(mgs,li) + cx(mgs,lc)) + ENDIF + + sctmp = frac*scx(mgs,lc) +! scx(mgs,li) = scx(mgs,li) + scx(mgs,lc) + scx(mgs,li) = scx(mgs,li) + sctmp +! thetap(mgs) = thetap(mgs) + fcc3(mgs)*qx(mgs,lc) +! ptwfzi(mgs) = fcc3(mgs)*qx(mgs,lc)*dtpinv +! qx(mgs,lc) = 0.0 +! cx(mgs,lc) = 0.0 +! scx(mgs,lc) = 0.0 + thetap(mgs) = thetap(mgs) + fcc3(mgs)*qtmp + ptwfzi(mgs) = fcc3(mgs)*qtmp*dtpinv + qx(mgs,lc) = qx(mgs,lc) - qtmp + cx(mgs,lc) = cx(mgs,lc) - ctmp + scx(mgs,lc) = scx(mgs,lc) - sctmp + end if + end do + + ENDIF ! warmonly +! +! do mgs = 1,ngscnt +! qwfzi(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv ! Not used?? (ERM) +! end do +! +! reset temporaries for cloud particles and vapor +! + qcond(:) = 0.0 + + IF ( ipconc .le. 1 .and. lwsm6 ) THEN ! Explicit cloud condensation/evaporation (Rutledge and Hobbs 1983) + DO mgs = 1,ngscnt + + qcwtmp(mgs) = qx(mgs,lc) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) +! temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temsav = temg(mgs) +! thsave(mgs) = thetap(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + + IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN + tmp = (qvap(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) ) + qcond(mgs) = Min( Max( 0.0, tmp ), (qvap(mgs)-qvs(mgs)) ) + IF ( qx(mgs,lc) > qxmin(lc) .and. tmp < 0.0 ) THEN ! evaporation + qcond(mgs) = Max( tmp, -qx(mgs,lc) ) + ENDIF + qwvp(mgs) = qwvp(mgs) - qcond(mgs) + qvap(mgs) = qvap(mgs) - qcond(mgs) + qx(mgs,lc) = Max( 0.0, qx(mgs,lc) + qcond(mgs) ) + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs)) + + ENDIF + + ENDDO + + ENDIF + + + IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN +! IF ( ipconc .le. 1 ) THEN + + do mgs = 1,ngscnt + qx(mgs,lv) = max( 0.0, qvap(mgs) ) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qx(mgs,li) = max( 0.0, qx(mgs,li) ) + qitmp(mgs) = qx(mgs,li) + end do +! +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) + temg(mgs) = theta(mgs)*(pinit(kgs(mgs)) + p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap + temsav = temg(mgs) + thsave(mgs) = thetap(mgs) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) +! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN +! C$PAR CRITICAL SECTION +! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs), +! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs), +! : ltemq,igs(mgs),jy,kgs(mgs) +! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt), +! : ab(igs(mgs),jy,kgs(mgs),lt), +! : t0(igs(mgs),jy,kgs(mgs)) +! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs) +! STOP +! C$PAR END CRITICAL SECTION +! END IF + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) +! qss(kz) = qvs(kz) +! if ( temg(kz) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) +! qss(kz) = qis(kz) +! end if +! dont get enough condensation with qcw .le./.gt. qxmin(lc) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if + end do +! +! iterate adjustment +! + do itertd = 1,2 +! + do mgs = 1,ngscnt +! +! calculate super-saturation +! + qitmp(mgs) = qx(mgs,li) + fcci(mgs) = 0.0 + fcip(mgs) = 0.0 + dqcw(mgs) = 0.0 + dqci(mgs) = 0.0 + dqwv(mgs) = ( qx(mgs,lv) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qx(mgs,lc) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qx(mgs,lc) + dqwv(mgs) = dqwv(mgs) + qx(mgs,lc) + end if +! + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit + dqci(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all ice available for sublimation + dqci(mgs) = -qitmp(mgs) + dqwv(mgs) = dqwv(mgs) + qitmp(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor +! +! This next line removed 3/19/2003 thanks to Adam Houston, +! who found the bug in the 3-ICE code +! qwvp(mgs) = max(qwvp(mgs), 0.0) + qitmp(mgs) = qx(mgs,li) + IF ( qitmp(mgs) .ge. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 1.0 + ENDIF + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) + qx(mgs,li) = qx(mgs,li) + dqci(mgs) * fcci(mgs) + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) & + & +(felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN + +! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) +! + qitmp(mgs) = qx(mgs,li) + fracl(mgs) = 1.0 + fraci(mgs) = 0.0 + if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then + fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) + fraci(mgs) = 1.0-fracl(mgs) + end if + if ( temg(mgs) .le. thnuc ) then + fraci(mgs) = 1.0 + fracl(mgs) = 0.0 + end if + fraci(mgs) = 1.0-fracl(mgs) +! + gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & + & / (pi0(mgs)) +! + IF ( temg(mgs) .lt. tfr ) then + IF (qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + END IF + IF ( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbi)**2)) + END IF + IF ( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + cdw = caw*pi0(mgs)*tfrcbw/((temg(mgs)-cbw)**2) + cdi = cai*pi0(mgs)*tfrcbi/((temg(mgs)-cbi)**2) + denom1 = qx(mgs,lc) + qitmp(mgs) + denom2 = 1.0 + gamss* & + & (qx(mgs,lc)*qvs(mgs)*cdw + qitmp(mgs)*qis(mgs)*cdi) / denom1 + dqvcnd(mgs) = dqwv(mgs) / denom2 + END IF + + ENDIF ! temg(mgs) .lt. tfr +! + if ( temg(mgs) .ge. tfr ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + end if +! + delqci1=qx(mgs,li) +! + IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 1.0 + ENDIF +! + dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) + dqci(mgs) = dqvcnd(mgs)*fraci(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & + & / (pi0(mgs)) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (0 & + & +felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) +! IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + qx(mgs,li) = qx(mgs,li) + dqci(mgs)*fcci(mgs) + qitmp(mgs) = qx(mgs,li) +! ENDIF +! +! delqci(mgs) = dqci(mgs)*fcci(mgs) +! + END IF ! dqwv(mgs) .ge. 0. + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + qx(mgs,lv) = max( 0.0, qvap(mgs)) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +!c if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +!c if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if +! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv +! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) + end do +! +! end the saturation adjustment iteration loop +! + end do + + ENDIF ! ( ipconc .le. 1 ) + +! +! spread the growth owing to vapor diffusion onto the +! ice crystal categories using the +! +! END OF SATURATION ADJUSTMENT +! + + if (ndebug .gt. 0 ) write(0,*) 'conc 30b' +! +! +! end of saturation adjustment + +! +! +! !DIR$ IVDEP + do mgs = 1,ngscnt + t0(igs(mgs),jy,kgs(mgs)) = temg(mgs) + end do +! +! Load the save arrays +! + + +! Sample code for using the axtra array to load microphysical rates or quantities for output +! IF ( io_flag .and. nxtra > 1 ) THEN +! DO mgs = 1,ngscnt +! axtra(igs(mgs),jy,kgs(mgs),1) = pfrz(mgs) ! +! axtra(igs(mgs),jy,kgs(mgs),2) = qrcev(mgs) ! pre2 +! axtra(igs(mgs),jy,kgs(mgs),3) = psub(mgs) ! depsubr +! axtra(igs(mgs),jy,kgs(mgs),4) = qrfrz(mgs) ! rain freezing (Bigg) +! axtra(igs(mgs),jy,kgs(mgs),5) = pmlt(mgs) ! melr2 +! ENDDO +! ENDIF + + + + + if (ndebug .gt. 0 ) write(0,*) 'gs 11' + + do mgs = 1,ngscnt +! + an(igs(mgs),jy,kgs(mgs),lt) = & + & theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) + qv0(mgs) ! + + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF +! + + DO il = lc,lhab + IF ( ido(il) .eq. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) + & + & min( an(igs(mgs),jy,kgs(mgs),il), 0.0 ) + qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il) + ENDIF + ENDDO + + IF ( lcina > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lcina) = cina(mgs) + ENDIF + + +! + end do +! + + if ( ipconc .ge. 1 ) then + DO il = lc,lhab !{ + +! write(0,*) 'limiter loop: il,ipc,lz: ',il,ipc(il),lz(il),ipconc + + IF ( ipconc .ge. ipc(il) .and. ido(il) > 0 ) THEN ! { + + IF ( ipconc .ge. 4 .and. ipc(il) .ge. 1 ) THEN ! { + +! write(0,*) 'MY limiter: il,ipc,lz: ',il,ipc(il),lz(il),lr,lzr +! STOP + + IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN ! { { is a two-moment category so dont worry about reflectivity + + + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .le. 0.0 ) THEN + cx(mgs,il) = 0.0 + ELSE !{ + IF ( cx(mgs,il) .gt. cxmin ) THEN !{ +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(cxmin,cx(mgs,il))) + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*cx(mgs,il)) + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,qx,xdn,ln = ',xv(mgs,il),cx(mgs,il),qx(mgs,il),xdn(mgs,il),ln(il) +! ENDIF + + ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also + IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. (il == ls .and. imusnow == 3 ) ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSE + xvbarmax = xvmx(il) + ENDIF + + tmp = 1.0 + IF ( il == ls ) THEN + xvbarmax = xvbarmax*Max(1.,100./Min(100.,xdn(mgs,ls))) + ENDIF + + IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvbarmax ) THEN + xv(mgs,il) = Min( xvbarmax, xv(mgs,il) ) + xv(mgs,il) = Max( xvmn(il), xv(mgs,il) ) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il)) + ENDIF + + ENDIF !} + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,= ',xv(mgs,il),cx(mgs,il) +! ENDIF + + ENDIF !} + ENDDO ! mgs + + + ENDIF ! }} + ENDIF ! } + + DO mgs = 1,ngscnt + IF ( il == lhl ) THEN + ENDIF + an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) + ENDDO + ENDIF ! } + ENDDO ! il } + + IF ( lcin > 1 ) THEN + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lcin) = Max(0.0, ccin(mgs)) + end do + ENDIF + + IF ( ipconc .ge. 2 ) THEN + do mgs = 1,ngscnt + IF ( lss > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lss) = Max(0.0, ssmax(mgs) ) + ENDIF + + IF ( lccn > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + end do + ENDIF + + ELSEIF ( ipconc .eq. 0 .and. lni .gt. 1 ) THEN + + DO mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lni) = Max(cx(mgs,li), 0.0) + ENDDO + + + end if + + IF ( ldovol ) THEN + + DO il = li,lhab + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + + an(igs(mgs),jy,kgs(mgs),lvol(il)) = Max( 0.0, vx(mgs,il) ) + ENDDO + + ENDIF + + ENDDO + + ENDIF +! +! +! +! +! + if (ndebug .gt. 0 ) write(0,*) 'gs 12' + + + + if (ndebug .gt. 0 ) write(0,*) 'gs 13' + + 9998 continue + + if ( kz .gt. nz-1 .and. ix .ge. itile) then + if ( ix .ge. itile ) then + go to 1200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if + + if ( ix .ge. itile ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if + + 1000 continue + 1200 continue +! +! end of gather scatter (for this jy slice) +! +! + + return + end subroutine nssl_2mom_gs +! +!-------------------------------------------------------------------------- +! + + + +! +!-------------------------------------------------------------------------- +! + + +END MODULE module_mp_nssl_2mom diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 new file mode 100644 index 000000000..a965ea849 --- /dev/null +++ b/physics/mp_nsslg.F90 @@ -0,0 +1,704 @@ +!>\file mp_nsslg.F90 +!! This file contains NSSL 2-moment MP scheme. + + +!>\defgroup aansslg NSSL MP Module +!! This module contains the NSSL microphysics scheme. +module mp_nsslg + + use machine, only : kind_phys, kind_real + use module_mp_nssl_2mom, only : nssl_2mom_init, nssl_2mom_driver + + implicit none + + public :: mp_nsslg_init, mp_nsslg_run, mp_nsslg_finalize + + private + logical :: is_initialized = .False. + real :: nssl_qccn + + contains + +!> This subroutine is a wrapper around the nssl_2mom_init(). +!! \section arg_table_mp_nsslg_init Argument Table +!! \htmlinclude mp_nsslg_init.html +!! + subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & + mpicomm, mpirank, mpiroot, & + imp_physics, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & + nssl_cccn, nssl_alphah, nssl_alphahl, nssl_hail_on) + + implicit none + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + + integer, intent(in) :: mpicomm + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + integer, intent(in) :: threads + integer, intent(in) :: imp_physics + integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn + real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl + logical, intent(in) :: nssl_hail_on + + ! Local variables: dimensions used in nssl_init + integer :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real :: nssl_params(20) + integer :: ihailv + + + + errflg = 0 + errmsg = '' + + + if (is_initialized) return + + if (mpirank==mpiroot) then + write(0,*) ' ----------------------------------------------------------------------------------------------------------------' + write(0,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development, use at your own risk --- WARNING ---' + write(0,*) ' ----------------------------------------------------------------------------------------------------------------' + write(6,*) ' ----------------------------------------------------------------------------------------------------------------' + write(6,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development, use at your own risk --- WARNING ---' + write(6,*) ' ----------------------------------------------------------------------------------------------------------------' + end if + +! IF ( kind_phys /= kind_real ) THEN +! errflg = 1 +! write(errmsg,'(a)') 'NSSL MP does not yet work for double precision. Compile for single precision' +! return +! ENDIF + + ! Set internal dimensions + ids = 1 + ims = 1 + its = 1 + ide = ncol + ime = ncol + ite = ncol + jds = 1 + jms = 1 + jts = 1 + jde = 1 + jme = 1 + jte = 1 + kds = 1 + kms = 1 + kts = 1 + kde = nlev + kme = nlev + kte = nlev + + is_initialized = .true. + + nssl_params(:) = 0.0 + nssl_params(1) = nssl_cccn + nssl_params(2) = nssl_alphah + nssl_params(3) = nssl_alphahl + nssl_params(4) = 4.e5 ! nssl_cnoh + nssl_params(5) = 4.e4 ! nssl_cnohl + nssl_params(6) = 4.e5 ! nssl_cnor + nssl_params(7) = 4.e6 ! nssl_cnos + nssl_params(8) = 500. ! nssl_rho_qh + nssl_params(9) = 800. ! nssl_rho_qhl + nssl_params(10) = 100. ! nssl_rho_qs + nssl_params(11) = 0 ! nssl_ipelec_tmp + nssl_params(12) = 11 ! nssl_isaund + nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off + + nssl_qccn = nssl_cccn/1.225 + if (mpirank==mpiroot) then + write(*,*) 'nssl_init: nssl_qccn = ',nssl_qccn + endif + + IF ( nssl_hail_on ) THEN + ihailv = 1 + ELSE + ihailv = -1 + ENDIF + + IF ( imp_physics == imp_physics_nssl2m ) THEN +! write(0,*) 'call nssl_2mom_init' + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) +! write(0,*) 'done nssl_2mom_init' + ELSEIF ( imp_physics == imp_physics_nssl2mccn ) THEN +! write(0,*) 'call nssl_2mom_init ccn' + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) +! write(0,*) 'done nssl_2mom_init ccn' + ELSE +! write(0,*) 'call nssl_2mom_init ccn: imp_physics, imp_physics_nssl2mccn = ',imp_physics, imp_physics_nssl2mccn + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) +! write(0,*) 'done nssl_2mom_init ccn' + ENDIF + + end subroutine mp_nsslg_init + +!>\ingroup aansslg +!>\section gen_nsslg NSSL MP General Algorithm +!>@{ +!> \section arg_table_mp_nsslg_run Argument Table +!! \htmlinclude mp_nsslg_run.html +!! + subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & +! spechum, cccn, qc, qr, qi, qs, qh, qhl, & + spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & + ccw, crw, cci, csw, chw, chl, vh, vhl, & + tgrs, prslk, prsl, phii, omega, dtp, & + prcp, rain, graupel, ice, snow, sr, & + refl_10cm, do_radar_ref, first_time_step, & + re_cloud, re_ice, re_snow, & + imp_physics, & + imp_physics_nssl2m, imp_physics_nssl2mccn, & + nssl_hail_on, nssl_invertccn, ntccn, ntccna, & + errflg, errmsg) + implicit none + integer, intent(in) :: ncol, nlev + real(kind_phys), intent(in ) :: con_g + real(kind_phys), intent(in ) :: con_rd + ! Hydrometeors + real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccn(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccna(1:ncol,1:nlev) + 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) :: qhl(1:ncol,1:nlev) ! hail + 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) :: chl(1:ncol,1:nlev) ! hail number + real(kind_phys), intent(inout) :: vh(1:ncol,1:nlev) ! graupel volume + real(kind_phys), intent(inout) :: vhl(1:ncol,1:nlev) ! hail volume + ! State variables and timestep information + real(kind_phys), intent(inout) :: tgrs(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prsl(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prslk(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: phii(1:ncol,1:nlev+1) + real(kind_phys), intent(in ) :: omega(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: dtp + ! Precip/rain/snow/graupel fall amounts and fraction of frozen precip + real(kind_phys), intent( out) :: prcp(1:ncol) + real(kind_phys), intent( out) :: rain(1:ncol) + real(kind_phys), intent( out) :: graupel(1:ncol) + real(kind_phys), intent( out) :: ice(1:ncol) + real(kind_phys), intent( out) :: snow(1:ncol) + real(kind_phys), intent( out) :: sr(1:ncol) + ! Radar reflectivity + real(kind_phys), intent( out) :: refl_10cm(1:ncol,1:nlev) + logical, intent(in ) :: do_radar_ref, first_time_step + ! Cloud effective radii + real(kind_phys), optional, intent( out) :: re_cloud(1:ncol,1:nlev) + real(kind_phys), optional, intent( out) :: re_ice(1:ncol,1:nlev) + real(kind_phys), optional, intent( out) :: re_snow(1:ncol,1:nlev) + integer, intent(in) :: imp_physics + integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn + logical, intent(in) :: nssl_hail_on, nssl_invertccn + integer, intent(in) :: ntccn, ntccna + + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + + + ! Local variables + + ! Air density + real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 + ! Hydrometeors + real(kind_phys) :: qv_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qc_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qr_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qi_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qs_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qh_mp(1:ncol,1:nlev) !< kg kg-1 (graupel dry mixing ratio) + real(kind_phys) :: qhl_mp(1:ncol,1:nlev) !< kg kg-1 (hail dry mixing ratio) + real(kind_phys) :: cn_mp(1:ncol,1:nlev) + real(kind_phys) :: cna_mp(1:ncol,1:nlev) + ! create temporaries for hail in case it does not exist + real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) + real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + ! Vertical velocity and level width + real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1 + real(kind_phys) :: dz(1:ncol,1:nlev) !< m + + ! Rain/snow/graupel fall amounts + real(kind_phys) :: rain_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: graupel_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: ice_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: snow_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: delta_rain_mp(1:ncol) ! mm + real(kind_phys) :: delta_graupel_mp(1:ncol) ! mm + real(kind_phys) :: delta_ice_mp(1:ncol) ! mm + real(kind_phys) :: delta_snow_mp(1:ncol) ! mm + + real(kind_phys) :: xrain_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xgraupel_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xice_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xsnow_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xdelta_rain_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_graupel_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_ice_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_snow_mp(1:ncol) ! mm + + ! Radar reflectivity + logical :: diagflag ! must be true if do_radar_ref is true, not used otherwise + integer :: do_radar_ref_mp ! integer instead of logical do_radar_ref + ! Effective cloud radii + logical :: do_effective_radii + real(kind_phys) :: re_cloud_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_ice_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_snow_mp(1:ncol,1:nlev) ! m + integer :: has_reqc + integer :: has_reqi + integer :: has_reqs + ! Dimensions used in driver + integer :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, i,j,k + integer :: itimestep = 0 ! timestep counter + integer :: ntmul, n + real, parameter :: dtpmax = 300. ! 600. ! 120. + real(kind_phys) :: dtptmp + integer, parameter :: ndebug = 0 + logical, parameter :: convertdry = .true. + logical :: invertccn + + + + errflg = 0 + errmsg = '' + + IF ( ndebug > 1 ) write(0,*) 'In physics nsslg_run' + + + ! Check initialization state + if (.not.is_initialized) then + write(errmsg, fmt='((a))') 'mp_nssl_run called before mp_nssl_init' + errflg = 1 + return + end if + + invertccn = nssl_invertccn + + !> - Convert specific humidity/moist mixing ratios to dry mixing ratios + qv_mp = spechum/(1.0_kind_phys-spechum) + IF ( convertdry ) THEN + qc_mp = qc/(1.0_kind_phys-spechum) + qr_mp = qr/(1.0_kind_phys-spechum) + qi_mp = qi/(1.0_kind_phys-spechum) + qs_mp = qs/(1.0_kind_phys-spechum) + qh_mp = qh/(1.0_kind_phys-spechum) + IF ( nssl_hail_on ) THEN + qhl_mp = qhl/(1.0_kind_phys-spechum) + ENDIF + ELSE +! qv_mp = spechum ! /(1.0_kind_phys-spechum) + qc_mp = qc ! /(1.0_kind_phys-spechum) + qr_mp = qr ! /(1.0_kind_phys-spechum) + qi_mp = qi ! /(1.0_kind_phys-spechum) + qs_mp = qs ! /(1.0_kind_phys-spechum) + qh_mp = qh ! /(1.0_kind_phys-spechum) + IF ( nssl_hail_on ) THEN + qhl_mp = qhl ! /(1.0_kind_phys-spechum) + ENDIF + + ENDIF + + IF ( nssl_hail_on ) THEN + chl_mp = chl + vhl_mp = vhl + ELSE + qhl_mp = 0 + chl_mp = 0 + vhl_mp = 0 + ENDIF + + + !> - Density of air in kg m-3 + rho = prsl/(con_rd*tgrs) + + !> - Convert omega in Pa s-1 to vertical velocity w in m s-1 + w = -omega/(rho*con_g) + + !> - Layer width in m from geopotential in m2 s-2 + dz = (phii(:,2:nlev+1) - phii(:,1:nlev)) / con_g + + ! Accumulated values inside scheme, not used; + ! only use delta and add to inout variables (different units) + rain_mp = 0 + graupel_mp = 0 + ice_mp = 0 + snow_mp = 0 + delta_rain_mp = 0 + delta_graupel_mp = 0 + delta_ice_mp = 0 + delta_snow_mp = 0 + xrain_mp = 0 + xgraupel_mp = 0 + xice_mp = 0 + xsnow_mp = 0 + xdelta_rain_mp = 0 + xdelta_graupel_mp = 0 + xdelta_ice_mp = 0 + xdelta_snow_mp = 0 + + IF ( ndebug >= 1 ) THEN + write(*,*) 'Max q before micro' + write(*,*) 'qc = ',1000.*maxval(qc_mp) + write(*,*) 'qr = ',1000.*maxval(qr_mp) + write(*,*) 'qi = ',1000.*maxval(qi_mp) + write(*,*) 'qs = ',1000.*maxval(qs_mp) + write(*,*) 'qh = ',1000.*maxval(qh_mp) + IF ( nssl_hail_on ) write(*,*) 'qhl = ',1000.*maxval(qhl_mp) + write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) + ENDIF + + ! Flags for calculating radar reflectivity; diagflag is redundant + if (do_radar_ref) then + diagflag = .true. + do_radar_ref_mp = 1 + else + diagflag = .false. + do_radar_ref_mp = 0 + end if + + if (present(re_cloud) .and. present(re_ice) .and. present(re_snow)) then + do_effective_radii = .true. + has_reqc = 1 + has_reqi = 1 + has_reqs = 1 + else if (.not.present(re_cloud) .and. .not.present(re_ice) .and. .not.present(re_snow)) then + do_effective_radii = .false. + has_reqc = 0 + has_reqi = 0 + has_reqs = 0 + else + write(errmsg,fmt='(*(a))') 'Logic error in mp_nssl_run:', & + ' all or none of the following optional', & + ' arguments are required: re_cloud, re_ice, re_snow' + errflg = 1 + return + end if + ! Initialize to zero, intent(out) variables + re_cloud_mp = 0 + re_ice_mp = 0 + re_snow_mp = 0 + + ! Set internal dimensions + ids = 1 + ims = 1 + its = 1 + ide = ncol + ime = ncol + ite = ncol + jds = 1 + jms = 1 + jts = 1 + jde = 1 + jme = 1 + jte = 1 + kds = 1 + kms = 1 + kts = 1 + kde = nlev + kme = nlev + kte = nlev + + + IF ( ndebug > 1 ) write(0,*) 'call nssl_2mom_driver' + + IF ( dtp > 1.5*dtpmax ) THEN + ntmul = Nint( dtp/dtpmax ) + dtptmp = dtp/ntmul + ELSE + dtptmp = dtp + ntmul = 1 + ENDIF + + IF ( first_time_step ) THEN + itimestep = 2 + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( invertccn ) THEN + cccn = 0 + !cccn = nssl_qccn + ELSE + cccn = nssl_qccn + ENDIF + ENDIF + ELSE + itimestep = 2 + ENDIF + + + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( invertccn ) THEN +! cn_mp = Max(0.0, nssl_qccn - Max(0.0,cccn)) + DO k = 1,nlev + DO i = 1,ncol + cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn(i,k)) ) +! cn_mp(i,k) = Min(nssl_qccn, nssl_qccn - cccn(i,k) ) + ENDDO + ENDDO + ! DO k = 1,nlev + ! DO i = 1,ncol + ! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) + ! cn_mp(i,k) = cccn(i,k) + ! ENDDO + ! ENDDO + ELSE + cn_mp = cccn + ENDIF + IF ( ntccna > 0 ) THEN +! cna_mp = cccna + ELSE + cna_mp = 0 + ENDIF + ENDIF + + + DO n = 1,ntmul + + itimestep = itimestep + 1 + + + + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + + + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & + CCW=ccw, & + CRW=crw, & + CCI=cci, & + CSW=csw, & + CHW=chw, & + CHL=chl_mp, & + VHW=vh, & + VHL=vhl_mp, & + cn=cn_mp, & +! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use + cna=cna_mp, f_cna=.false. , & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & +! icenc=ice_mp, icencv=delta_ice_mp, & + GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & + dbz = refl_10cm, & +! nssl_progn=.false., & + diagflag = diagflag, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + + ELSE + + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & +! CCW=qnc_mp, & + CCW=ccw, & + CRW=crw, & + CCI=cci, & + CSW=csw, & + CHW=chw, & + CHL=chl_mp, & + VHW=vh, & + VHL=vhl_mp, & + ! cn=cccn, & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & +! icenc=ice_mp, icencv=delta_ice_mp, & + GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & + dbz = refl_10cm, & +! nssl_progn=.false., & + diagflag = diagflag, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + ENDIF + + + DO i = 1,ncol + delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) + delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) + delta_ice_mp(i) = delta_ice_mp(i) + xdelta_ice_mp(i) + delta_snow_mp(i) = delta_snow_mp(i) + xdelta_snow_mp(i) + ENDDO + + ENDDO + + + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( invertccn ) THEN + !cccn = Max(0.0, nssl_qccn - cn_mp ) + DO k = 1,nlev + DO i = 1,ncol +! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) + cccn(i,k) = nssl_qccn - cn_mp(i,k) + ENDDO + ENDDO + ELSE + cccn = cn_mp + ENDIF +! cccna = cna_mp + ENDIF + +! test code +! IF ( ntccna > 1 .and. do_effective_radii ) THEN +! cccna = re_ice_mp*1.0E6_kind_phys +! ENDIF + + IF ( ndebug > 1 ) write(0,*) 'done nssl_2mom_driver' + + if (errflg/=0) return + + IF ( ndebug >= 1 ) THEN + write(*,*) 'Max q after micro' + write(*,*) 'qc = ',1000.*maxval(qc_mp) + write(*,*) 'qr = ',1000.*maxval(qr_mp) + write(*,*) 'qi = ',1000.*maxval(qi_mp) + write(*,*) 'qs = ',1000.*maxval(qs_mp) + write(*,*) 'qh = ',1000.*maxval(qh_mp) + IF ( nssl_hail_on ) THEN + write(*,*) 'qhl = ',1000.*maxval(qhl_mp) + ENDIF + write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) + IF ( 1000.*maxval(qc_mp) > 0.5 .or. 1000.*maxval(qi_mp) > 0.09 .or. 1000.*maxval(qs_mp) > 0.1 ) THEN + IF ( imp_physics == imp_physics_nssl2mccn ) THEN + write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' + DO k = 1,nlev + write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, ccw(1,k)*rho(1,k)*1.e-6, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 + ENDDO + ELSE + write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' + DO k = 1,nlev + write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, 0.0, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 + ENDDO + ENDIF + ENDIF + ENDIF + + IF ( nssl_hail_on ) THEN + chl = chl_mp + vhl = vhl_mp + ENDIF + + !> - Convert dry mixing ratios to specific humidity/moist mixing ratios + spechum = qv_mp/(1.0_kind_phys+qv_mp) + IF ( convertdry ) THEN + qc = qc_mp/(1.0_kind_phys+qv_mp) + qr = qr_mp/(1.0_kind_phys+qv_mp) + qi = qi_mp/(1.0_kind_phys+qv_mp) + qs = qs_mp/(1.0_kind_phys+qv_mp) + qh = qh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_hail_on ) THEN + qhl = qhl_mp/(1.0_kind_phys+qv_mp) + ENDIF + ELSE +! spechum = qv_mp ! /(1.0_kind_phys+qv_mp) + qc = qc_mp ! /(1.0_kind_phys+qv_mp) + qr = qr_mp ! /(1.0_kind_phys+qv_mp) + qi = qi_mp ! /(1.0_kind_phys+qv_mp) + qs = qs_mp ! /(1.0_kind_phys+qv_mp) + qh = qh_mp ! /(1.0_kind_phys+qv_mp) + IF ( nssl_hail_on ) THEN + qhl = qhl_mp ! /(1.0_kind_phys+qv_mp) + ENDIF + + ENDIF + +! write(0,*) 'mp_nsslg: done q' + + !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables + ! "rain" in NSSL MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) + + prcp = max(0.0, delta_rain_mp/1000.0_kind_phys) + graupel = max(0.0, delta_graupel_mp/1000.0_kind_phys) + ice = max(0.0, delta_ice_mp/1000.0_kind_phys) + snow = max(0.0, delta_snow_mp/1000.0_kind_phys) + rain = max(0.0, delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp)/1000.0_kind_phys) + +! write(0,*) 'mp_nsslg: done precip' + + if (do_effective_radii) then + ! Convert m to micron + re_cloud = re_cloud_mp*1.0E6_kind_phys + re_ice = re_ice_mp*1.0E6_kind_phys + re_snow = re_snow_mp*1.0E6_kind_phys + end if + + IF ( ndebug > 1 ) write(0,*) 'mp_nsslg: end' + + end subroutine mp_nsslg_run +!>@} + +#if 0 +!! \section arg_table_mp_nsslg_finalize Argument Table +!! \htmlinclude mp_nsslg_finalize.html +!! +#endif + subroutine mp_nsslg_finalize(errflg, errmsg) + implicit none + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + errflg = 0 + errmsg = '' + + + end subroutine mp_nsslg_finalize + +end module mp_nsslg diff --git a/physics/mp_nsslg.meta b/physics/mp_nsslg.meta new file mode 100644 index 000000000..95a11826e --- /dev/null +++ b/physics/mp_nsslg.meta @@ -0,0 +1,578 @@ +[ccpp-table-properties] + name = mp_nsslg + type = scheme + dependencies = machine.F,module_mp_nssl_2mom.F90 + +[ccpp-arg-table] + name = mp_nsslg_init + type = scheme +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[nlev] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[mpicomm] + standard_name = mpi_comm + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in + optional = F +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[threads] + standard_name = omp_threads + long_name = number of OpenMP threads available to scheme + units = count + dimensions = () + type = integer + intent = in + optional = F +[imp_physics] + standard_name = flag_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F +[nssl_cccn] + standard_name = nssl_ccn_concentration + long_name = CCN concentration + units = m-3 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[nssl_alphah] + standard_name = nssl_alpha_graupel + long_name = graupel PSD shape parameter in NSSL micro + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[nssl_alphahl] + standard_name = nssl_alpha_hail + long_name = hail PSD shape parameter in NSSL micro + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = mp_nsslg_run + type = scheme +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[nlev] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[spechum] + standard_name = water_vapor_specific_humidity_updated_by_physics + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qc] + standard_name = cloud_condensed_water_mixing_ratio_updated_by_physics + long_name = cloud water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qr] + standard_name = rain_water_mixing_ratio_updated_by_physics + long_name = rain water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qi] + standard_name = ice_water_mixing_ratio_updated_by_physics + long_name = ice water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qs] + standard_name = snow_water_mixing_ratio_updated_by_physics + long_name = snow water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qh] + standard_name = graupel_mixing_ratio_updated_by_physics + long_name = graupel mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qhl] + standard_name = hail_mixing_ratio_updated_by_physics + long_name = moist (dry+vapor, no condensates) mixing ratio of hail updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cccn] + standard_name = cloud_condensation_nuclei_number_concentration_updated_by_physics + long_name = number concentration of cloud condensation nuclei updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cccna] + standard_name = activated_cloud_condensation_nuclei_number_concentration_updated_by_physics + long_name = number concentration of activated cloud condensation nuclei updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ccw] + standard_name = cloud_droplet_number_concentration_updated_by_physics + long_name = cloud droplet number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[crw] + standard_name = rain_number_concentration_updated_by_physics + long_name = rain number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cci] + standard_name = ice_number_concentration_updated_by_physics + long_name = ice number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[csw] + standard_name = snow_number_concentration_updated_by_physics + long_name = snow number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[chw] + standard_name = graupel_number_concentration_updated_by_physics + long_name = graupel number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[chl] + standard_name = hail_number_concentration_updated_by_physics + long_name = hail number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[vh] + standard_name = graupel_volume_updated_by_physics + long_name = graupel particle volume + units = m3 kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[vhl] + standard_name = hail_volume_updated_by_physics + long_name = hail particle volume + units = m3 kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tgrs] + standard_name = air_temperature_updated_by_physics + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[omega] + standard_name = omega + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[prcp] + standard_name = lwe_thickness_of_explicit_precipitation_amount + long_name = explicit precipitation (rain, ice, snow, graupel) on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rain] + standard_name = lwe_thickness_of_explicit_rain_amount + long_name = explicit rain fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[graupel] + standard_name = lwe_thickness_of_graupel_amount + long_name = graupel fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ice] + standard_name = lwe_thickness_of_ice_amount + long_name = ice fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snow] + standard_name = lwe_thickness_of_snow_amount + long_name = snow fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[sr] + standard_name = ratio_of_snowfall_to_rainfall + long_name = ratio of snowfall to large-scale rainfall + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[refl_10cm] + standard_name = radar_reflectivity_10cm + long_name = instantaneous refl_10cm + units = dBZ + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[do_radar_ref] + standard_name = flag_for_radar_reflectivity + long_name = flag for radar reflectivity + units = flag + dimensions = () + type = logical + intent = in + optional = F +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[re_cloud] + standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle_in_um + long_name = eff. radius of cloud liquid water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = T +[re_ice] + standard_name = effective_radius_of_stratiform_cloud_ice_particle_in_um + long_name = eff. radius of cloud ice water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = T +[re_snow] + standard_name = effective_radius_of_stratiform_cloud_snow_particle_in_um + long_name = effective radius of cloud snow particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = T +[imp_physics] + standard_name = flag_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in + optional = F +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F +[ntccn] + standard_name = index_for_cloud_condensation_nuclei_number_concentration + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntccna] + standard_name = index_for_activated_cloud_condensation_nuclei_number_concentration + long_name = tracer index for activated cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = mp_nsslg_finalize + 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 + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + From c8bbd69abfb84a78b295ec780ca289ee1b7bab82 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 31 Mar 2021 21:00:16 -0500 Subject: [PATCH 029/217] - Fixes subroutine end statements (causes error on some older compilers) --- physics/h2ointerp.f90 | 4 ++-- physics/ozinterp.f90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/h2ointerp.f90 b/physics/h2ointerp.f90 index fe7acaed3..f26ae6c0c 100644 --- a/physics/h2ointerp.f90 +++ b/physics/h2ointerp.f90 @@ -123,7 +123,7 @@ subroutine setindxh2o(npts,dlat,jindx1,jindx2,ddy) enddo return - end + end subroutine setindxh2o ! !********************************************************************** ! @@ -201,6 +201,6 @@ subroutine h2ointerpol(me,npts,idate,fhour,jindx1,jindx2,h2oplout,ddy) enddo ! return - end + end subroutine h2ointerpol end module h2ointerp diff --git a/physics/ozinterp.f90 b/physics/ozinterp.f90 index acb63efbf..6fe86c8e1 100644 --- a/physics/ozinterp.f90 +++ b/physics/ozinterp.f90 @@ -129,7 +129,7 @@ SUBROUTINE setindxoz(npts,dlat,jindx1,jindx2,ddy) ENDDO RETURN - END + END SUBROUTINE setindxoz ! !********************************************************************** ! @@ -206,6 +206,6 @@ SUBROUTINE ozinterpol(me,npts,IDATE,FHOUR,jindx1,jindx2,ozplout,ddy) enddo ! RETURN - END + END SUBROUTINE ozinterpol end module ozinterp From a5f236f85531e7bb730c9efe1cbe5b4c76c6919b Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 1 Apr 2021 15:14:10 -0500 Subject: [PATCH 030/217] Add missing 'nthl' to call interface --- physics/GFS_rrtmg_pre.F90 | 2 +- physics/GFS_rrtmg_pre.meta | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 029c71637..df9c6e2ed 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,7 +18,7 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, ntwa, ntoz, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & imp_physics_nssl2m, imp_physics_nssl2mccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index a018e0577..07f562fd5 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -163,6 +163,14 @@ dimensions = () type = integer intent = in +[nthl] + standard_name = index_for_hail + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in + optional = F [ntwa] standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array long_name = tracer index for water friendly aerosol From e38406a2dec155c51ce6b9e89451fa3f858c843c Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 2 Apr 2021 00:14:37 -0500 Subject: [PATCH 031/217] - Pass effrr into NSSL driver - Split NSSL conditional in GFS_rrtmg_pre.F90 from Thompson for now - Text comments in radiation_clouds.f --- physics/GFS_rrtmg_pre.F90 | 39 ++++++++++++++++++++++++++++++++++++-- physics/mp_nsslg.F90 | 4 +++- physics/mp_nsslg.meta | 9 +++++++++ physics/radiation_clouds.f | 7 +++++-- 4 files changed, 54 insertions(+), 5 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index df9c6e2ed..da086a743 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -1032,10 +1032,45 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & effri_inout(:,:), effrs_inout(:,:), & dzb, xlat_d, julian, yearlen, & clouds,cldsa,mtopa,mbota, de_lgth, alpha) ! --- outputs + elseif( imp_physics == imp_physics_nssl2m & + .or. imp_physics == imp_physics_nssl2mccn & + ) then ! Thompson MP + + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + !-- MYNN PBL or convective GF + !-- use cloud fractions with SGS clouds + do k=1,lmk + do i=1,im + clouds(i,k,1) = clouds1(i,k) + enddo + enddo + + ! --- use clduni as with the GFDL microphysics. + ! --- make sure that effr_in=.true. in the input.nml! + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + xlat, xlon, slmsk, dz, delp, IM, LMK, LMP, & + clouds(:,1:LMK,1), & + effrl, effri, effrr, effrs, effr_in , & + dzb, xlat_d, julian, yearlen, & + clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs + + else + ! MYNN PBL or GF convective are not used + call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + xlat,xlon,slmsk,dz,delp, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntsw-1,ntgl-1, & + im, lmk, lmp, uni_cld, lmfshal, lmfdeep2, & + cldcov(:,1:LMK), effrl_inout(:,:), & + effri_inout(:,:), effrs_inout(:,:), & + dzb, xlat_d, julian, yearlen, & + clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs + endif ! MYNN PBL or GF + elseif(imp_physics == imp_physics_thompson & - .or. imp_physics == imp_physics_nssl2m & - .or. imp_physics == imp_physics_nssl2mccn & +! .or. imp_physics == imp_physics_nssl2m & +! .or. imp_physics == imp_physics_nssl2mccn & ) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index a965ea849..66e207568 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -152,7 +152,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & tgrs, prslk, prsl, phii, omega, dtp, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, & - re_cloud, re_ice, re_snow, & + re_cloud, re_ice, re_snow, re_rain, & imp_physics, & imp_physics_nssl2m, imp_physics_nssl2mccn, & nssl_hail_on, nssl_invertccn, ntccn, ntccna, & @@ -200,6 +200,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & real(kind_phys), optional, intent( out) :: re_cloud(1:ncol,1:nlev) real(kind_phys), optional, intent( out) :: re_ice(1:ncol,1:nlev) real(kind_phys), optional, intent( out) :: re_snow(1:ncol,1:nlev) + real(kind_phys), optional, intent( out) :: re_rain(1:ncol,1:nlev) integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn logical, intent(in) :: nssl_hail_on, nssl_invertccn @@ -678,6 +679,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & re_cloud = re_cloud_mp*1.0E6_kind_phys re_ice = re_ice_mp*1.0E6_kind_phys re_snow = re_snow_mp*1.0E6_kind_phys + re_rain = 1.0E3_kind_phys end if IF ( ndebug > 1 ) write(0,*) 'mp_nsslg: end' diff --git a/physics/mp_nsslg.meta b/physics/mp_nsslg.meta index 95a11826e..63786ecd2 100644 --- a/physics/mp_nsslg.meta +++ b/physics/mp_nsslg.meta @@ -480,6 +480,15 @@ kind = kind_phys intent = out optional = T +[re_rain] + standard_name = effective_radius_of_stratiform_cloud_rain_particle_in_um + long_name = effective radius of cloud rain particle in micrometers + units = um + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F [imp_physics] standard_name = flag_for_microphysics_scheme long_name = choice of microphysics scheme diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index dacf6e38e..8c0565eac 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -280,6 +280,7 @@ module module_radiation_clouds !!\n =6: WSM6 microphysics !!\n =10: MG microphysics !!\n =15: Ferrier-Aligo microphysics +!!\n =17/18: NSSL microphysics !!\param me print control flag !>\section gen_cld_init cld_init General Algorithm !! @{ @@ -370,6 +371,8 @@ subroutine cld_init & print *,' --- MG cloud microphysics' elseif (imp_physics == 15) then print *,' --- Ferrier-Aligo cloud microphysics' + elseif (imp_physics == 17 .or. imp_physics == 18) then + print *,' --- NSSL cloud microphysics' else print *,' !!! ERROR in cloud microphysc specification!!!', & & ' imp_physics (NP3D) =',imp_physics @@ -2855,7 +2858,7 @@ end subroutine progcld5 !mz: this is the original progcld5 for Thompson MP (and WSM6), -! to be replaced by the GSL version of progcld6 for Thompson MP +! to be replaced by the GSL version of progcld6 for Thompson MP and NSSL subroutine progcld6 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & @@ -2870,7 +2873,7 @@ subroutine progcld6 & ! ================= subprogram documentation block ================ ! ! ! ! subprogram: progcld6 computes cloud related quantities using ! -! Thompson/WSM6 cloud microphysics scheme. ! +! Thompson/WSM6/NSSL cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! ! condensates, ! From 841eab216550ce4fd42d9e6f250cbf35d538d9d3 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 2 Apr 2021 10:41:04 -0500 Subject: [PATCH 032/217] Turned off a print statement. --- physics/module_mp_nssl_2mom.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 9b73797c4..93cb1ea5f 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -2103,8 +2103,8 @@ SUBROUTINE nssl_2mom_init( & iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; ENDIF - IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac - IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac +! IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac +! IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac RETURN From 72e76935f8be34b17ad9bae6718cc72abe53d481 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 2 Apr 2021 11:06:50 -0500 Subject: [PATCH 033/217] Restore the incorrectly removed flags. --- physics/GFS_rrtmg_pre.meta | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 07f562fd5..01865ab98 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -250,6 +250,21 @@ type = integer intent = in optional = F +[imp_physics_nssl2m] + standard_name = flag_for_nssl2m_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_nssl2mccn] + standard_name = flag_for_nssl2mccn_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme with CCN + units = flag + dimensions = () + type = integer + intent = in- optional = F [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme From d9f2ced5900e89a151678683b9ded4501b6867d6 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 2 Apr 2021 13:12:49 -0500 Subject: [PATCH 034/217] Turn off setting rain radius for now. --- physics/mp_nsslg.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index 66e207568..3034d9012 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -679,7 +679,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & re_cloud = re_cloud_mp*1.0E6_kind_phys re_ice = re_ice_mp*1.0E6_kind_phys re_snow = re_snow_mp*1.0E6_kind_phys - re_rain = 1.0E3_kind_phys +! re_rain = 1.0E3_kind_phys end if IF ( ndebug > 1 ) write(0,*) 'mp_nsslg: end' From 2b92bcb1a0d700dd7fe659cf074fc7cfa95debfc Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Tue, 6 Apr 2021 12:07:52 -0500 Subject: [PATCH 035/217] Fixed typo in meta file --- physics/GFS_rrtmg_pre.meta | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 01865ab98..7825b3263 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -264,7 +264,8 @@ units = flag dimensions = () type = integer - intent = in- optional = F + intent = in + optional = F [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme From 8157607c25dca4a32fd6ed1c4aebc0e157ffdf92 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Tue, 6 Apr 2021 12:16:42 -0500 Subject: [PATCH 036/217] Fixed typo and missing declaration --- physics/GFS_rrtmg_pre.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index da086a743..b695fe767 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -85,7 +85,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv_gf, me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & ntcw, ntiw, ntlnc, ntinc, & - ntrw, ntsw, ntgl, ntwa, ntoz, & + ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & kdt, imp_physics, & From a8f39482c2d2769f85142e9deaa523e1cc88308f Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 8 Apr 2021 13:31:45 -0500 Subject: [PATCH 037/217] - Fixed setting of itimestep on first model step. This was preventing calcnfromq from running, which creates number concentration from the initial condition hydrometeor mass --- physics/mp_nsslg.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index 3034d9012..7bf7b8233 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -426,7 +426,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ENDIF IF ( first_time_step ) THEN - itimestep = 2 + itimestep = 0 IF ( imp_physics == imp_physics_nssl2mccn ) THEN IF ( invertccn ) THEN cccn = 0 From 59445605d08dee5c279b81fee9aedc9931ed5973 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 9 Apr 2021 10:42:07 -0500 Subject: [PATCH 038/217] Turned on zeroing out of hail for low number concentration. Some spurious points of very small mass with large reflectivity were showing up, perhaps because of the very large time step in UFS (40s). This helps eliminate those. --- physics/module_mp_nssl_2mom.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 93cb1ea5f..7b2dcc6f6 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1410,6 +1410,8 @@ SUBROUTINE nssl_2mom_init( & ENDIF ENDIF + IF ( iresetmoments == 0 ) iresetmoments = lhl + ! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl ! IF ( ipelec > 0 ) idonic = .true. From 3ec235b6ce9f7aee35fc569fc484e93101979aaa Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Mon, 12 Apr 2021 09:36:41 -0500 Subject: [PATCH 039/217] Added extra printout info for large fall speeds. --- physics/module_mp_nssl_2mom.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 7b2dcc6f6..29bc4ed31 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -6410,6 +6410,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y + write(0,*) 'q, number, diam1,3(mm) = ', qx(mgs,il),cx(mgs,il),1000.*xdia(mgs,il,1),1000.*xdia(mgs,il,3) ! call commasmpi_abort() ENDIF ! & (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))* & From 74dd53c61c7890a4ebed9aff4c8cfe63ae83c41a Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 14 Apr 2021 16:57:34 -0500 Subject: [PATCH 040/217] Call calcnfromq on every time step, which helps keep boundaries a bit cleaner. Changes to calcnfromq to set droplet number as 9 micron radius droplets, and then deplete CCN if turned on. Also set masses to zero if less than qxmin. --- physics/module_mp_nssl_2mom.F90 | 61 +++++++++++++++++++++++++++------ 1 file changed, 50 insertions(+), 11 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 29bc4ed31..1eed6a1d0 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -2702,9 +2702,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! #ifndef CM1 ! for real cases when hydrometeor mixing ratios have been initialized without concentrations - IF ( itimestep == 1 .and. ipconc > 0 ) THEN +! IF ( itimestep == 1 .and. ipconc > 0 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) - ENDIF +! ENDIF ! #endif IF ( present(cu_used) .and. & @@ -4515,6 +4515,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real, parameter :: zsfac = 1./(pi*xdns*xn0s) real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet real xv,xdn integer :: ndbz, nmwgt, nnwgt, nwlessthanz @@ -4548,23 +4549,41 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! Cloud droplets IF ( lnc > 1 ) THEN - IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN - an(ix,jy,kz,lnc) = qccn + IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + + an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)/cwmas09 )*dn(ix,kz) + + IF ( lccn > 1 .and. lccna < 1 ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc) + ENDIF + IF ( lccna > 1 ) THEN + an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) + ENDIF + + ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) ) THEN + + an(ix,jy,kz,lnc) = 0.0 + an(ix,jy,kz,lc) = 0.0 + ENDIF ENDIF ! Cloud ice IF ( lni > 1 ) THEN - IF ( an(ix,jy,kz,lni) <= 0.1*cxmin .and. an(ix,jy,kz,li) > qxmin(li) ) THEN - an(ix,jy,kz,lni) = an(ix,jy,kz,li)/xims + IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin(li) ) THEN + an(ix,jy,kz,lni) = dn(ix,kz)*an(ix,jy,kz,li)/xims + + ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) ) THEN + an(ix,jy,kz,lni) = 0.0 + an(ix,jy,kz,li) = 0.0 ENDIF ENDIF ! rain IF ( lnr > 1 ) THEN - IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin(lr) ) THEN + IF ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) > qxmin(lr) ) THEN q = an(ix,jy,kz,lr) @@ -4576,12 +4595,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio + ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) ) THEN + an(ix,jy,kz,lnr) = 0.0 + an(ix,jy,kz,lr) = 0.0 ENDIF ENDIF ! snow IF ( lns > 1 ) THEN - IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin(ls) ) THEN + IF ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) > qxmin(ls) ) THEN q = an(ix,jy,kz,ls) @@ -4593,13 +4615,16 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio + ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) ) THEN + an(ix,jy,kz,lns) = 0.0 + an(ix,jy,kz,ls) = 0.0 ENDIF ENDIF ! graupel IF ( lnh > 1 ) THEN - IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN + IF ( an(ix,jy,kz,lnh) < cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN IF ( lvh > 1 ) THEN IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh @@ -4614,15 +4639,25 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) nrx = n1*g1h/g0 ! number concentration for different shape parameter - an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio + IF ( nrx > cxmin ) THEN + an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio + ELSE + an(ix,jy,kz,lh) = 0.0 + an(ix,jy,kz,lnh) = 0.0 + an(ix,jy,kz,lvh) = 0.0 + ENDIF + ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) ) THEN + + an(ix,jy,kz,lh) = 0.0 + ENDIF ENDIF ! hail IF ( lnhl > 1 .and. lhl > 1 ) THEN - IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN + IF ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN IF ( lvhl > 1 ) THEN IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl @@ -4639,6 +4674,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio + ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) ) THEN + + an(ix,jy,kz,lhl) = 0.0 + ENDIF ENDIF From 4ccadc0618faf0011159936d80e554d210c1308b Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sun, 18 Apr 2021 20:51:57 -0500 Subject: [PATCH 041/217] Removed re_rain from interface (not used and not planning to use this way) --- physics/mp_nsslg.F90 | 15 ++++++++------- physics/mp_nsslg.meta | 9 --------- 2 files changed, 8 insertions(+), 16 deletions(-) diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index 7bf7b8233..85731baa5 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -95,7 +95,6 @@ subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & kme = nlev kte = nlev - is_initialized = .true. nssl_params(:) = 0.0 nssl_params(1) = nssl_cccn @@ -137,6 +136,8 @@ subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & ! write(0,*) 'done nssl_2mom_init ccn' ENDIF + is_initialized = .true. + end subroutine mp_nsslg_init !>\ingroup aansslg @@ -152,7 +153,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & tgrs, prslk, prsl, phii, omega, dtp, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, & - re_cloud, re_ice, re_snow, re_rain, & + re_cloud, re_ice, re_snow, & imp_physics, & imp_physics_nssl2m, imp_physics_nssl2mccn, & nssl_hail_on, nssl_invertccn, ntccn, ntccna, & @@ -194,13 +195,13 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & real(kind_phys), intent( out) :: snow(1:ncol) real(kind_phys), intent( out) :: sr(1:ncol) ! Radar reflectivity - real(kind_phys), intent( out) :: refl_10cm(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: refl_10cm(1:ncol,1:nlev) logical, intent(in ) :: do_radar_ref, first_time_step ! Cloud effective radii - real(kind_phys), optional, intent( out) :: re_cloud(1:ncol,1:nlev) - real(kind_phys), optional, intent( out) :: re_ice(1:ncol,1:nlev) - real(kind_phys), optional, intent( out) :: re_snow(1:ncol,1:nlev) - real(kind_phys), optional, intent( out) :: re_rain(1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_cloud(1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_ice(1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_snow(1:ncol,1:nlev) +! real(kind_phys), optional, intent( out) :: re_rain(1:ncol,1:nlev) integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn logical, intent(in) :: nssl_hail_on, nssl_invertccn diff --git a/physics/mp_nsslg.meta b/physics/mp_nsslg.meta index 63786ecd2..95a11826e 100644 --- a/physics/mp_nsslg.meta +++ b/physics/mp_nsslg.meta @@ -480,15 +480,6 @@ kind = kind_phys intent = out optional = T -[re_rain] - standard_name = effective_radius_of_stratiform_cloud_rain_particle_in_um - long_name = effective radius of cloud rain particle in micrometers - units = um - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F [imp_physics] standard_name = flag_for_microphysics_scheme long_name = choice of microphysics scheme From b4d03795909d508e05e2c19795a2da57997fc6c7 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sun, 18 Apr 2021 20:52:39 -0500 Subject: [PATCH 042/217] Updated calcnfromq to use qxmin_init for higher mass thresholds. Lower mixing ratios masses are transferred to water vapor. Also added second estimate for graupel number conc. and take minimum. Added air density limit in setvtz and nssl_2mom_gs to limit fall speed or rhovt. Added limit on Bigg freezing to only act if freezing radius is 8mm or less. --- physics/module_mp_nssl_2mom.F90 | 461 ++++++++++++-------------------- 1 file changed, 167 insertions(+), 294 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 1eed6a1d0..174cca092 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1,7 +1,7 @@ !WRF:MODEL_LAYER:PHYSICS -! prepocessed on "Oct 16 2020" at "14:58:00" +! prepocessed on "Apr 18 2021" at "20:33:31" @@ -148,7 +148,6 @@ MODULE module_mp_nssl_2mom public nssl_2mom_driver public nssl_2mom_init - public nssl_2mom_init_aero private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis private gamma_dp, gamxinfdp, gamma_dpr private delbk, delabk @@ -221,12 +220,12 @@ MODULE module_mp_nssl_2mom real , private :: auttim = 300. ! 10-ice rain delay time real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual -!#if (NMM_CORE == 1) +#if (NMM_CORE == 1) ! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true -! logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state -!#else + logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state +#else logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state -!#endif +#endif logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) @@ -247,7 +246,7 @@ MODULE module_mp_nssl_2mom ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. - real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) + real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed @@ -270,6 +269,7 @@ MODULE module_mp_nssl_2mom integer, private :: ndebug = -1, ncdebug = 0 integer, private :: ipconc = 5 + integer, private :: inucopt = 0 integer, private :: ichaff = 0 integer, parameter :: ilimit = 0 @@ -296,7 +296,7 @@ MODULE module_mp_nssl_2mom integer, private :: ireadmic = 0 - integer, private :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data + integer, private :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data; =2 for Geoffroy et al. (2010, ACP) integer, private :: iccwflg = 1 ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid) ! (first nucleation is done with a KW sat. adj. step) integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field @@ -769,6 +769,7 @@ MODULE module_mp_nssl_2mom real cno(lc:lqmx) real xvmn(lc:lqmx), xvmx(lc:lqmx) real qxmin(lc:lqmx) + real qxmin_init(lc:lqmx) integer nqsat parameter (nqsat=1000001) ! (nqsat=20001) @@ -816,7 +817,7 @@ MODULE module_mp_nssl_2mom real, parameter :: dhmn0 = 0.3e-3 real, private :: dhmn = dhmn0, dhmx = -1. - real, parameter :: cwradn = 2.5e-7, xcradmn = cwradn ! minimum radius + real, parameter :: cwradn = 2.0e-6, xcradmn = cwradn ! minimum radius real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius real, parameter :: cwc1 = 6.0/(pi*1000.) @@ -1109,182 +1110,6 @@ END FUNCTION fqis -! ##################################################################### -! ArcHyperbolic tangent to handle only positive values of argument - - REAL FUNCTION myatanh(x) - implicit none - real :: x - - IF ( x >= 0.0 .and. x < 1.0 ) THEN - myatanh = 0.5*( Log((x + 1.0)/(1. - x))) ! 0.5*( Log(x + 1.0) - Log(1. - x)) - ELSEIF ( x >= 1.0 ) THEN - myatanh = 1.e32 - ELSE - myatanh = 0 - ENDIF - - END FUNCTION myatanh - -! ##################################################################### -! ##################################################################### - SUBROUTINE nssl_2mom_init_aero(hgt, nwfa2d, nwfa, nifa, qnn2d, qnn, dx, dy, cccn, & - is_start, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte) - -! This subroutine code is mostly borrowed from thompson_init in module_mp_thompson.F -! Here, it is a separate initialization only of things related to aerosols - - IMPLICIT NONE - - INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: hgt - -!..OPTIONAL variables that control application of aerosol-aware scheme - - REAL, DIMENSION(ims:ime,kms:kme,jms:jme), OPTIONAL, INTENT(INOUT) :: qnn,nwfa, nifa - REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL, INTENT(INOUT) :: nwfa2d,qnn2d - REAL, OPTIONAL, INTENT(IN) :: DX, DY, cccn - LOGICAL, OPTIONAL, INTENT(IN) :: is_start - CHARACTER*256:: mp_debug - - - INTEGER:: i, j, k, l, m, n - REAL:: h_01, niIN3, niCCN3, max_test - - REAL, PARAMETER :: eps = 1.E-15 -! LOGICAL:: has_CCN, has_IN - - is_aerosol_aware = .FALSE. -! micro_init = .FALSE. -! has_CCN = .FALSE. -! has_IN = .FALSE. - - - write(mp_debug,*) ' DEBUG checking column of hgt ', its+1,jts+1 - CALL wrf_debug(250, mp_debug) - do k = kts, kte - write(mp_debug,*) ' DEBUGT k, hgt = ', k, hgt(its+1,k,jts+1) - CALL wrf_debug(250, mp_debug) - enddo - - if (PRESENT(qnn2d) .AND. PRESENT(qnn) .AND. PRESENT(nifa)) is_aerosol_aware = .TRUE. - - if (is_aerosol_aware) then - - turn_on_cin = .true. - -!..Check for existing aerosol data, both CCN and IN aerosols. If missing -!.. fill in just a basic vertical profile, somewhat boundary-layer following. - - max_test = MAXVAL ( qnn(its:ite-1,:,jts:jte-1) ) - - if (max_test .lt. eps) then - write(mp_debug,*) ' Apparently there are no initial CCN aerosols, so we will initialize using nssl_cccn value.' - CALL wrf_debug(100, mp_debug) - write(mp_debug,*) ' checked column at point (i,j) = ', its,jts - CALL wrf_debug(100, mp_debug) - do j = jts, min(jde-1,jte) - do i = its, min(ide-1,ite) - do k = 1, kte - qnn(i,k,j) = cccn/1.225 ! naCCN1+naCCN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niCCN3) - enddo - enddo - enddo - else -! has_CCN = .TRUE. - write(mp_debug,*) ' Apparently initial CCN aerosols are present.' - CALL wrf_debug(100, mp_debug) - write(mp_debug,*) ' column sum at point (i,j) = ', its,jts, SUM(qnn(its,:,jts)) - CALL wrf_debug(100, mp_debug) - endif - - - max_test = MAXVAL ( nifa(its:ite-1,:,jts:jte-1) ) - - if (max_test .lt. eps) then - write(mp_debug,*) ' Apparently there are no initial IN aerosols.' - CALL wrf_debug(100, mp_debug) - write(mp_debug,*) ' checked column at point (i,j) = ', its,jts - CALL wrf_debug(100, mp_debug) - do j = jts, min(jde-1,jte) - do i = its, min(ide-1,ite) - if (hgt(i,1,j).le.1000.0) then - h_01 = 0.8 - elseif (hgt(i,1,j).ge.2500.0) then - h_01 = 0.01 - else - h_01 = 0.8*cos(hgt(i,1,j)*0.001 - 1.0) - endif - niIN3 = -1.0*ALOG(naIN1/naIN0)/h_01 - nifa(i,1,j) = naIN1+naIN0*exp(-((hgt(i,2,j)-hgt(i,1,j))/1000.)*niIN3) - do k = 2, kte - nifa(i,k,j) = naIN1+naIN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niIN3) - enddo - enddo - enddo - else -! has_IN = .TRUE. - write(mp_debug,*) ' Apparently initial IN aerosols are present.' - CALL wrf_debug(100, mp_debug) - write(mp_debug,*) ' column sum at point (i,j) = ', its,jts, SUM(nifa(its,:,jts)) - CALL wrf_debug(100, mp_debug) - endif - -!..Capture initial state lowest level CCN aerosol data in 2D array. - -! do j = jts, min(jde-1,jte) -! do i = its, min(ide-1,ite) -! qnn2d(i,j) = qnn(i,kts,j) -! enddo -! enddo - -!..Scale the lowest level aerosol data into an emissions rate. This is -!.. very far from ideal, but need higher emissions where larger amount -!.. of existing and lesser emissions where not already lots of aerosols -!.. for first-order simplistic approach. Later, proper connection to -!.. emission inventory would be better, but, for now, scale like this: -!.. where: Nwfa=50 per cc, emit 0.875E4 aerosols per kg per second -!.. Nwfa=500 per cc, emit 0.875E5 aerosols per kg per second -!.. Nwfa=5000 per cc, emit 0.875E6 aerosols per kg per second -!.. for a grid with 20km spacing and scale accordingly for other spacings. - - if (is_start) then - if (SQRT(DX*DY)/20000.0 .ge. 1.0) then - h_01 = 0.875 - else - h_01 = (0.875 + 0.125*((20000.-SQRT(DX*DY))/16000.)) * SQRT(DX*DY)/20000. - endif - write(mp_debug,*) ' aerosol surface flux emission scale factor is: ', h_01 - CALL wrf_debug(100, mp_debug) - do j = jts, min(jde-1,jte) - do i = its, min(ide-1,ite) - ! qnn2d(i,j) = 10.0**(LOG10(qnn(i,kts,j)*1.E-6)-3.69897) - ! qnn2d(i,j) = qnn2d(i,j)*h_01 * 1.E6 - qnn2d(i,j) = (qnn(i,kts,j))/5000. ! same as above -- scale to 5000s for full restore - qnn2d(i,j) = qnn2d(i,j)*h_01 - - nwfa2d(i,j) = 10.0**(LOG10(nwfa(i,kts,j)*1.E-6)-3.69897) - nwfa2d(i,j) = nwfa2d(i,j)*h_01 * 1.E6 - - enddo - enddo -! else -! write(mp_debug,*) ' sample (lower-left) aerosol surface flux emission rate: ', qnn2d(1,1) -! CALL wrf_debug(100, mp_debug) - endif - - endif - - - - RETURN -END SUBROUTINE nssl_2mom_init_aero - ! ##################################################################### ! ##################################################################### @@ -1301,7 +1126,6 @@ SUBROUTINE nssl_2mom_init( & & nssl_snowfallfac & ) - implicit none real, intent(in), optional :: & @@ -1332,12 +1156,12 @@ SUBROUTINE nssl_2mom_init( & real :: alp,ratio double precision :: x,y,y2,y7 - logical :: turn_on_ccna + logical :: turn_on_ccna, turn_on_cina integer :: istat turn_on_ccna = .false. -! turn_on_cin = .false. + turn_on_cina = .false. ! ! set some global values from namelist input ! @@ -1409,9 +1233,8 @@ SUBROUTINE nssl_2mom_init( & ! idoci = 0 ! try this later ENDIF ENDIF - - IF ( iresetmoments == 0 ) iresetmoments = lhl - + + IF ( iresetmoments == 0 ) iresetmoments = 1 ! lhl ! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl ! IF ( ipelec > 0 ) idonic = .true. @@ -1702,6 +1525,12 @@ SUBROUTINE nssl_2mom_init( & denscale(ltmp) = 1 ENDIF + IF ( turn_on_cina ) THEN + ltmp = ltmp + 1 + lcina = ltmp + denscale(ltmp) = 1 + ENDIF + IF ( turn_on_cin .or. is_aerosol_aware ) THEN ltmp = ltmp + 1 lcin = ltmp @@ -2025,6 +1854,7 @@ SUBROUTINE nssl_2mom_init( & IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12 IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12 + qxmin_init(:) = 1.0e-8 ! threshold for considering single-moment initial condition mixing ratios ! constants for droplet nucleation cckm = cck-1. @@ -2116,7 +1946,7 @@ END SUBROUTINE nssl_2mom_init ! ##################################################################### SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & - cn, vhw, vhl, cna, f_cn, f_cna, & + cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & zrw, zhw, zhl, & qsw, qhw, qhlw, & tt, th, pii, p, w, dn, dz, dtp, itimestep, & @@ -2193,7 +2023,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw zrw, zhw, zhl, & qsw, qhw, qhlw, & qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) @@ -2241,7 +2071,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, optional, intent(in) :: dx,dy real, intent(in):: dtp integer, intent(in):: itimestep !, ccntype - logical, optional, intent(in) :: diagflag, f_cna, f_cn + logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina integer, optional, intent(in) :: ipelectmp, ke_diag LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem @@ -2308,7 +2138,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed double precision :: timevtcalc,timesetvt - logical :: f_cnatmp + logical :: f_cnatmp, f_cinatmp integer :: kediagloc integer :: iunit @@ -2348,6 +2178,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSE f_cnatmp = .false. ENDIF + + IF ( present( f_cina ) ) THEN + f_cinatmp = f_cina + ELSE + f_cinatmp = .false. + ENDIF IF ( present( vzf ) ) vzflag0 = 1 @@ -2383,45 +2219,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw renucfrac = 1.0 ENDIF -! set up CCN array and some other static local values - IF ( .false. ) THEN - IF ( itimestep == 1 .and. .not. invertccn .and. present( cn ) ) THEN - ! this is not needed for WRF 3.8 and later because it is done in physics_init, - ! but kept for backwards compatibility with earlier versions - IF ( cn((ite+its)/2,(kte+kts)/2,(jte+jts)/2) < 10.0 ) THEN ! initialize ccn if not already done - DO jy = jts,jte - DO kz = kts,kte - DO ix = its,ite - cn(ix,kz,jy) = qccn - ENDDO - ENDDO - ENDDO - ENDIF - ENDIF - - IF ( itimestep == 1 .and. invertccn .and. present( cn ) ) THEN - ! this is not needed for WRF 3.8 and later because it is done in physics_init, - ! but kept for backwards compatibility with earlier versions - DO jy = jts,jte - DO kz = kts,kte - DO ix = its,ite - cn(ix,kz,jy) = 0.0 - ENDDO - ENDDO - ENDDO - ENDIF - - IF ( invertccn .and. present( cn ) ) THEN ! hack for WRF to convert activated ccn to unactivated, then do not have to - ! worry about initial and boundary conditions - they are zero - DO jy = jts,jte - DO kz = kts,kte - DO ix = its,ite - ! cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) - ENDDO - ENDDO - ENDDO - ENDIF - ENDIF ! ENDIF ! itimestep == 1 @@ -2512,11 +2309,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( is_aerosol_aware .and. flag_qnwfa ) THEN an(ix,1,kz,lccn) = nwfa(ix,kz,jy) ELSEIF ( present( cn ) ) THEN - IF ( invertccn ) THEN - an(ix,1,kz,lccn) = qccn - cn(ix,kz,jy) - ELSE - an(ix,1,kz,lccn) = cn(ix,kz,jy) - ENDIF + IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN + an(ix,1,kz,lccna) = cn(ix,kz,jy) + an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = cn(ix,kz,jy) + ENDIF ELSE IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) @@ -2532,6 +2330,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw an(ix,1,kz,lccna) = cna(ix,kz,jy) ENDIF ENDIF + + IF ( lcina > 1 ) THEN + IF ( present( cni ) .and. f_cinatmp ) THEN + an(ix,1,kz,lcina) = cni(ix,kz,jy) + ENDIF + ENDIF IF ( lcin > 1 .and. flag_qnifa ) THEN an(ix,1,kz,lcin) = nifa(ix,kz,jy) @@ -2702,9 +2506,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! #ifndef CM1 ! for real cases when hydrometeor mixing ratios have been initialized without concentrations -! IF ( itimestep == 1 .and. ipconc > 0 ) THEN + IF ( itimestep == 1 .and. ipconc > 0 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) -! ENDIF + ENDIF ! #endif IF ( present(cu_used) .and. & @@ -2960,15 +2764,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! nwfa(ix,kz,jy) = Min(1.5e9, nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp) IF ( kz == 1 ) nwfa(ix,kz,jy) = nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN - IF ( invertccn ) THEN - cn(ix,kz,jy) = qccn - an(ix,1,kz,lccn) + IF ( lccna > 1 .and. .not. present( cna ) ) THEN + cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) ELSE cn(ix,kz,jy) = an(ix,1,kz,lccn) ENDIF ENDIF IF ( lccna > 1 ) THEN IF ( present( cna ) .and. f_cnatmp ) THEN - cna(ix,kz,jy) = an(ix,1,kz,lccna) + cna(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) + ENDIF + ENDIF + + IF ( lcina > 1 ) THEN + IF ( present( cni ) .and. f_cinatmp ) THEN + cni(ix,kz,jy) = Max(0.0, an(ix,1,kz,lcina) ) ENDIF ENDIF @@ -3003,15 +2813,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! jy - IF ( invertccn .and. present( cn ) ) THEN ! hack to convert unactivated ccn back to activated - DO jy = jts,jte - DO kz = kts,kte - DO ix = its,ite -! cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) - ENDDO - ENDDO - ENDDO - ENDIF @@ -3764,7 +3565,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO ix = ixb,ixe db1(ix,kz) = dn(ix,jy,kz) db1inv(ix,kz) = 1./dn(ix,jy,kz) - rhovtzx(kz,ix) = Sqrt(rho00*db1inv(ix,kz) ) + rhovtzx(kz,ix) = Sqrt(rho00*Min(1.0/0.05, db1inv(ix,kz))) ! prevent excessive rhovt ENDDO ENDDO @@ -4505,9 +4306,9 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) integer ix,jy,kz - double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv - real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4 + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) real, parameter :: zhfac = 1./(pi*xdnh*xn0h) @@ -4515,6 +4316,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real, parameter :: zsfac = 1./(pi*xdns*xn0s) real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx) real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet real xv,xdn @@ -4549,7 +4351,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! Cloud droplets IF ( lnc > 1 ) THEN - IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)/cwmas09 )*dn(ix,kz) @@ -4560,8 +4362,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) ENDIF - ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) ) THEN + ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. & + ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) an(ix,jy,kz,lnc) = 0.0 an(ix,jy,kz,lc) = 0.0 @@ -4571,10 +4375,12 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! Cloud ice IF ( lni > 1 ) THEN - IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin(li) ) THEN + IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin_init(li) ) THEN an(ix,jy,kz,lni) = dn(ix,kz)*an(ix,jy,kz,li)/xims - ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) ) THEN + ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) .or. & + ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) <= qxmin_init(li)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) an(ix,jy,kz,lni) = 0.0 an(ix,jy,kz,li) = 0.0 ENDIF @@ -4583,7 +4389,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! rain IF ( lnr > 1 ) THEN - IF ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) > qxmin(lr) ) THEN + IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin_init(lr) ) THEN q = an(ix,jy,kz,lr) @@ -4595,7 +4401,9 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio - ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) ) THEN + ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) .or. & + ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) <= qxmin_init(lr)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) an(ix,jy,kz,lnr) = 0.0 an(ix,jy,kz,lr) = 0.0 ENDIF @@ -4603,7 +4411,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! snow IF ( lns > 1 ) THEN - IF ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) > qxmin(ls) ) THEN + IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN q = an(ix,jy,kz,ls) @@ -4614,17 +4422,20 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) nrx = n1*g1s/g0 ! number concentration for different shape parameter an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio - - ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) ) THEN + + ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) .or. & + ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) <= qxmin_init(ls)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) an(ix,jy,kz,lns) = 0.0 an(ix,jy,kz,ls) = 0.0 + ENDIF ENDIF ! graupel IF ( lnh > 1 ) THEN - IF ( an(ix,jy,kz,lnh) < cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN + IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin_init(lh) ) THEN IF ( lvh > 1 ) THEN IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh @@ -4639,6 +4450,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) nrx = n1*g1h/g0 ! number concentration for different shape parameter + nrx2 = dn(ix,kz) * q / xgms + + nrx = Min( nrx, nrx2 ) + IF ( nrx > cxmin ) THEN an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio ELSE @@ -4647,8 +4462,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lvh) = 0.0 ENDIF - ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) ) THEN + ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) .or. & + ( an(ix,jy,kz,lnh) <= cxmin .and. an(ix,jy,kz,lh) <= qxmin_init(lh)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) an(ix,jy,kz,lh) = 0.0 ENDIF @@ -4657,7 +4474,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! hail IF ( lnhl > 1 .and. lhl > 1 ) THEN - IF ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN + IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin_init(lhl) ) THEN IF ( lvhl > 1 ) THEN IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl @@ -4674,8 +4491,11 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio - ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) ) THEN + + ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. & + ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) an(ix,jy,kz,lhl) = 0.0 ENDIF @@ -6388,7 +6208,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! { vtxbar(mgs,il,2) = & & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & - & (3.0*cd*rho0(mgs)) ) + & (3.0*cd*Max(0.05,rho0(mgs))) ) ELSE IF ( il == lh .and. icdx /= 6 ) bbx = bx(il) @@ -6492,7 +6312,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSE ! not lh or lhl vtxbar(mgs,il,2) = & & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & - & (3.0*cdx(il)*rho0(mgs)) ) + & (3.0*cdx(il)*Max(0.05,rho0(mgs))) ) vtxbar(mgs,il,3) = vtxbar(mgs,il,1) if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5' @@ -8076,6 +7896,7 @@ SUBROUTINE NUCOND & implicit none +! real :: cwmasn = 1000.*0.523599*(2.*2.e-6)**3 integer :: nx,ny,nz,na,nxi integer :: nor,norz, jyslab ! ,nht,ngt,igsr real :: dtp ! time step @@ -9631,6 +9452,9 @@ SUBROUTINE NUCOND & xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx ) xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn ) cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) +! IF ( cx(mgs,lc) > tmp*1.1 ) THEN +! write(0,*) 'nucond: kgs, ccw1,2 = ',kgs(mgs),tmp,cx(mgs,lc) +! ENDIF ENDIF ENDIF @@ -10448,19 +10272,15 @@ subroutine nssl_2mom_gs & real bfnu, bfnu0, bfnu1 parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0) ) real ventr, ventc - real volb, aa1, aa2 + real volb double precision t2s, xdp double precision xl2p(ngs),rb(ngs) - parameter ( aa1 = 9.44e15, aa2 = 5.78e3 ) ! a1 in Ziegler + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler ! snow parameters: - real cexs, cecs - parameter ( cexs = 0.1, cecs = 0.5 ) - real rvt ! ratio of collection kernels (Zrnic et al, 1993) - parameter ( rvt = 0.104 ) - real kfrag ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) - parameter ( kfrag = 1.0e-6 ) - real mfrag ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) - parameter ( mfrag = 1.0e-10) + real, parameter :: cexs = 0.1, cecs = 0.5 + real, parameter :: rvt = 0.104 ! ratio of collection kernels (Zrnic et al, 1993) + real, parameter :: kfrag = 1.0e-6 ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) + real, parameter :: mfrag = 1.0e-10 ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) double precision cautn(ngs), rh(ngs), nh(ngs) real ex1, ft, rhoinv(ngs) double precision ec0(ngs) @@ -11587,7 +11407,7 @@ subroutine nssl_2mom_gs & pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) rhoinv(mgs) = 1.0/rho0(mgs) - rhovt(mgs) = Sqrt(rho00/rho0(mgs)) + rhovt(mgs) = Sqrt(rho00/Max(0.05,rho0(mgs))) ! prevent excessive rhovt pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs)) @@ -11713,6 +11533,10 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + IF ( qx(mgs,li) .le. qxmin(li) ) THEN + cx(mgs,li) = 0.0 + ENDIF + IF ( lcina .gt. 1 ) THEN cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) ELSE @@ -11727,6 +11551,9 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) ! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + IF ( qx(mgs,lc) .le. qxmin(lc) ) THEN + cx(mgs,lc) = 0.0 + ENDIF IF ( lss > 1 ) THEN ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) ENDIF @@ -13839,8 +13666,23 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt csacs(mgs) = 0.0 IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 ) THEN ! .and. xv(mgs,ls) < 0.25*xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN - csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density - csacs(mgs) = min(csacs(mgs),csmxd(mgs)) + + IF ( iessec0flag == 0 ) THEN + ec0(mgs) = 1.0 + ELSE + tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass + IF ( tmp .lt. essfrac1 ) THEN + ec0(mgs) = 1.0 + ELSEIF ( tmp .gt. essfrac2 ) THEN + ec0(mgs) = 0.0 + ELSE + ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1) + ENDIF + ENDIF + + csacs(mgs) = ec0(mgs)*rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*essrmax**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density + csacs(mgs) = Min(csacs(mgs),csmxd(mgs)) ENDIF end do end if @@ -14441,12 +14283,13 @@ subroutine nssl_2mom_gs & IF ( ibiggopt == 2 .and. imurain == 1 ) THEN ! ! integrate from Bigg diameter (for given supercooling Ts) to infinity - volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 (Proc. Phys. Soc. London) ! for mean temperature for freezing: -ln (V) = a*Ts - b, where a = 6.9/6.8, or approx a = 1.0, and b = 16.2 ! volt is given in cm**3, so convert to m**3 dbigg = (6./pi* volt )**(1./3.) ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. + IF ( dbigg < 8.e-3 ) THEN !{ only bother if freezing diameter is reasonable ratio = Min(maxratiolu, dbigg/xdia(mgs,lr,1) ) @@ -14477,7 +14320,15 @@ subroutine nssl_2mom_gs & qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv qrfrzf(mgs) = qrfrz(mgs) + + IF ( qrfrz(mgs)*dtp < qxmin(lh) .or. crfrz(mgs)*dtp < cxmin ) THEN + crfrz(mgs) = 0.0 + qrfrz(mgs) = 0.0 + + ELSE !{ + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) @@ -14497,7 +14348,6 @@ subroutine nssl_2mom_gs & crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 - ELSE !{ ! recalculate using dhmn for ratio @@ -14543,6 +14393,8 @@ subroutine nssl_2mom_gs & qrfrzs(mgs) = 0.0 ENDIF ! } + ENDIF !} + IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) qrfrz(mgs) = fac*qrfrz(mgs) @@ -14552,6 +14404,9 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = fac*crfrzs(mgs) crfrzf(mgs) = fac*crfrzf(mgs) ENDIF + + ENDIF !} + ! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN ! fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr) ! crfrz(mgs) = fac*crfrz(mgs) @@ -16629,20 +16484,33 @@ subroutine nssl_2mom_gs & ELSEIF ( ihlcnh == 3 ) THEN !{ IF ( wtest .and. & - ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) ) THEN + ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN ! convert number, mass, and reflectivity for d > dw + IF ( ipconc == 5 ) THEN + dg0(mgs) = Min( dg0(mgs), hldia1 ) + !dg0(mgs) = hldia1 + ENDIF + ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) ! mass tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + IF ( ipconc == 5 ) THEN + ! tmp2 = Min( 0.25, tmp2 ) + ENDIF qxd1 = qx(mgs,lh)*(tmp2) qhlcnh(mgs) = dtpinv*qxd1 - IF ( qxd1 > qxmin(lhl) ) THEN + + + IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN ! number tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + IF ( ipconc == 5 ) THEN + ! tmp = Min( 0.2, tmp ) + ENDIF cxd1 = cx(mgs,lh)*( tmp) chlcnh(mgs) = dtpinv*cxd1 chlcnhhl(mgs) = chlcnh(mgs) @@ -19561,13 +19429,17 @@ subroutine nssl_2mom_gs & ! Sample code for using the axtra array to load microphysical rates or quantities for output +! +! Note that indices 1 and 2 are used in the nucond subroutine for condensation/evap of droplets (1) and +! condensation of rain (2) +! ! IF ( io_flag .and. nxtra > 1 ) THEN ! DO mgs = 1,ngscnt -! axtra(igs(mgs),jy,kgs(mgs),1) = pfrz(mgs) ! -! axtra(igs(mgs),jy,kgs(mgs),2) = qrcev(mgs) ! pre2 -! axtra(igs(mgs),jy,kgs(mgs),3) = psub(mgs) ! depsubr -! axtra(igs(mgs),jy,kgs(mgs),4) = qrfrz(mgs) ! rain freezing (Bigg) -! axtra(igs(mgs),jy,kgs(mgs),5) = pmlt(mgs) ! melr2 +! axtra(igs(mgs),jy,kgs(mgs),3) = pfrz(mgs) ! +! axtra(igs(mgs),jy,kgs(mgs),4) = qrcev(mgs) ! pre2 +! axtra(igs(mgs),jy,kgs(mgs),5) = psub(mgs) ! depsubr +! axtra(igs(mgs),jy,kgs(mgs),6) = qrfrz(mgs) ! rain freezing (Bigg) +! axtra(igs(mgs),jy,kgs(mgs),7) = pmlt(mgs) ! melr2 ! ENDDO ! ENDIF @@ -19633,7 +19505,8 @@ subroutine nssl_2mom_gs & ! ENDIF ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also - IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. (il == ls .and. imusnow == 3 ) ) THEN + IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. & + & (il == ls .and. imusnow == 3 ) ) THEN xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) From eae593d7c1c2d34070eb178ea800f5e2a3cabfbb Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 29 Apr 2021 11:34:57 -0500 Subject: [PATCH 043/217] Changed itimestep to a purely local variable (i.e., not saved) --- physics/mp_nsslg.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index 85731baa5..316b0c399 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -266,7 +266,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, i,j,k - integer :: itimestep = 0 ! timestep counter + integer :: itimestep ! timestep counter integer :: ntmul, n real, parameter :: dtpmax = 300. ! 600. ! 120. real(kind_phys) :: dtptmp From 48983e8f64eb74f05e4b40ca2c97705832f174df Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sun, 9 May 2021 18:27:31 -0500 Subject: [PATCH 044/217] Fixed bug in setting array values of "rain" (noticed by E. Aligo) --- physics/mp_nsslg.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_nsslg.F90 b/physics/mp_nsslg.F90 index 316b0c399..a2dc50cce 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nsslg.F90 @@ -671,7 +671,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & graupel = max(0.0, delta_graupel_mp/1000.0_kind_phys) ice = max(0.0, delta_ice_mp/1000.0_kind_phys) snow = max(0.0, delta_snow_mp/1000.0_kind_phys) - rain = max(0.0, delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp)/1000.0_kind_phys) + rain = max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) ! write(0,*) 'mp_nsslg: done precip' From 115aeb0247e4cb3fa553f11b8f0a3a23b0367179 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 30 Sep 2021 19:46:52 -0500 Subject: [PATCH 045/217] - Changed from two imp_physics_nssl flags to a single one with second flag for nssl_ccn_on - Updataed microphysics - Radiation (rrtmg) includes calculated rain radius. Test code to compute radii in the subroutine, but something not right with incoming number concentrations - Renamed mp_nsslg to mp_nssl --- physics/GFS_MP_generic.F90 | 12 +- physics/GFS_MP_generic.meta | 10 +- physics/GFS_PBL_generic.F90 | 44 +- physics/GFS_PBL_generic.meta | 36 +- physics/GFS_rrtmg_pre.F90 | 158 ++- physics/GFS_rrtmg_pre.meta | 66 +- physics/GFS_suite_interstitial.F90 | 19 +- physics/GFS_suite_interstitial.meta | 25 +- physics/maximum_hourly_diagnostics.F90 | 11 +- physics/maximum_hourly_diagnostics.meta | 10 +- physics/module_MYNNPBL_wrapper.F90 | 33 +- physics/module_MYNNPBL_wrapper.meta | 30 +- physics/module_mp_nssl_2mom.F90 | 1271 +++++++++++++++-------- physics/{mp_nsslg.F90 => mp_nssl.F90} | 498 ++++++--- physics/{mp_nsslg.meta => mp_nssl.meta} | 304 +++++- 15 files changed, 1809 insertions(+), 718 deletions(-) rename physics/{mp_nsslg.F90 => mp_nssl.F90} (58%) rename physics/{mp_nsslg.meta => mp_nssl.meta} (69%) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 588891b25..8d5e92265 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -85,8 +85,7 @@ end subroutine GFS_MP_generic_post_init !> \section gfs_mp_gen GFS MP Generic Post General Algorithm !> @{ subroutine GFS_MP_generic_post_run( & - im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & + 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, con_g, rainmin, dtf, frain, rainc, & rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, 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, & @@ -102,7 +101,7 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires - integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn + integer, intent(in) :: imp_physics_nssl logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm integer, intent(in) :: index_of_temperature,index_of_process_mp @@ -185,8 +184,7 @@ subroutine GFS_MP_generic_post_run( ice = ice0 snow = snow0 ! Do it right from the beginning for Thompson - else if (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl2m & - .or. imp_physics == imp_physics_nssl2mccn) then + else if (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl ) then tprcp = max (zero, rainc + frain * rain1) ! time-step convective and explicit precip graupel = frain*graupel0 ! time-step graupel ice = frain*ice0 ! time-step ice @@ -225,7 +223,7 @@ subroutine GFS_MP_generic_post_run( ! ! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation - if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson) then + if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson .and. imp_physics /= imp_physics_nssl) then do i=1,im tprcp(i) = max(zero, rain(i) ) if(doms(i) > zero .or. domip(i) > zero) then @@ -267,7 +265,7 @@ subroutine GFS_MP_generic_post_run( !! \f$0^oC\f$. if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. & - imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn) then + imp_physics == imp_physics_nssl ) then ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index d43cf9297..b5a6a43fb 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -213,7 +213,7 @@ dimensions = () type = integer intent = in -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -221,14 +221,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [cal_pre] standard_name = flag_for_dominant_precipitation_type_partition long_name = flag controls precip type algorithm diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index e2446dbf8..15246546e 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -14,15 +14,16 @@ module GFS_PBL_generic_common subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & imp_physics_thompson, ltaerosol, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, kk, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & errmsg, errflg) implicit none ! integer, intent(in ) :: imp_physics, imp_physics_wsm6, & imp_physics_thompson, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr - logical, intent(in ) :: ltaerosol + imp_physics_zhao_carr,imp_physics_nssl + logical, intent(in ) :: ltaerosol, nssl_hail_on, nssl_ccn_on integer, intent(out) :: kk character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -53,6 +54,13 @@ subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & elseif (imp_physics == imp_physics_zhao_carr) then ! Zhao/Carr/Sundqvist kk = 3 + elseif (imp_physics == imp_physics_nssl) then + IF ( nssl_hail_on ) THEN + kk = 16 + ELSE + kk = 13 + ENDIF + IF ( nssl_ccn_on ) kk = kk + 1 else write(errmsg,'(*(a))') 'Logic error: unknown microphysics option in set_aerosol_tracer_index' kk = -999 @@ -84,8 +92,8 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & ntccn, nthl, nthnc, ntgv, nthv, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, ltaerosol, & - imp_physics_nssl2m,imp_physics_nssl2mccn, ltaerosol, nssl_hail_on, & + imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, imp_physics_nssl, & + ltaerosol, nssl_ccn_on, nssl_hail_on, & hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) @@ -104,8 +112,8 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend - integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn - logical, intent(in) :: cplchm, ltaerosol, nssl_hail_on + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: cplchm, ltaerosol, nssl_hail_on, nssl_ccn_on real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs @@ -255,7 +263,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, enddo enddo rtg_ozone_index = 3 - elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + elseif (imp_physics == imp_physics_nssl ) then ! nssl IF ( nssl_hail_on ) THEN do k=1,levs @@ -276,7 +284,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, vdftra(i,k,14) = qgrs(i,k,ntgv) vdftra(i,k,15) = qgrs(i,k,nthv) vdftra(i,k,16) = qgrs(i,k,ntoz) - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN vdftra(i,k,17) = qgrs(i,k,ntccn) ENDIF enddo @@ -299,7 +307,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, vdftra(i,k,11) = qgrs(i,k,ntgnc) vdftra(i,k,12) = qgrs(i,k,ntgv) vdftra(i,k,13) = qgrs(i,k,ntoz) - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN vdftra(i,k,14) = qgrs(i,k,ntccn) ENDIF enddo @@ -314,7 +322,8 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, call set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & imp_physics_thompson, ltaerosol, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, kk, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & errmsg, errflg) if (errflg /= 0) return ! @@ -386,7 +395,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev,nqrimef, & trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, imp_physics_mg, & - imp_physics_fer_hires, imp_physics_nssl2m, imp_physics_nssl2mccn, & + imp_physics_fer_hires, imp_physics_nssl, nssl_ccn_on, & ltaerosol, nssl_hail_on, cplflx, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf,& shinhong, do_ysu, dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, & dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & @@ -407,7 +416,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires - integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn, nssl_hail_on + integer, intent(in) :: imp_physics_nssl, nssl_ccn_on, nssl_hail_on logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu @@ -478,7 +487,8 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, call set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & imp_physics_thompson, ltaerosol, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, kk, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & errmsg, errflg) if (errflg /= 0) return ! @@ -605,7 +615,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntoz) = dvdftra(i,k,3) enddo enddo - elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + elseif (imp_physics == imp_physics_nssl ) then ! nssl IF ( nssl_hail_on ) THEN do k=1,levs @@ -626,7 +636,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntgv) = dvdftra(i,k,14) dqdt(i,k,nthv) = dvdftra(i,k,15) dqdt(i,k,ntoz) = dvdftra(i,k,16) - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN dqdt(i,k,ntccn) = dvdftra(i,k,17) ENDIF enddo @@ -649,7 +659,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntgnc) = dvdftra(i,k,11) dqdt(i,k,ntgv) = dvdftra(i,k,12) dqdt(i,k,ntoz) = dvdftra(i,k,13) - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN dqdt(i,k,ntccn) = dvdftra(i,k,14) ENDIF enddo diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 842a95632..2f1cbdec6 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -271,7 +271,7 @@ dimensions = () type = integer intent = in -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -279,14 +279,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -294,6 +286,14 @@ dimensions = () type = logical intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro @@ -706,7 +706,7 @@ dimensions = () type = integer intent = in -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -714,14 +714,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -729,6 +721,14 @@ dimensions = () type = logical intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index b695fe767..10ba643bd 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,9 +18,9 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & - ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, first_time_step, & + imp_physics,imp_physics_nssl, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & imp_physics_fer_hires, julian, yearlen, lndp_var_list, lsswr, lslwr, & @@ -36,7 +36,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & gasvmr_o2, gasvmr_co, gasvmr_cfc11, gasvmr_cfc12, gasvmr_cfc22, & gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, faersw1, faersw2, faersw3, faerlw1, faerlw2, & - faerlw3, alpha, errmsg, errflg) + faerlw3, alpha, errmsg, errflg,mpiroot) use machine, only: kind_phys @@ -78,6 +78,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & make_DropletNumber, & make_RainNumber + use module_mp_nssl_2mom, only: calc_eff_radius, calcnfromq, na + implicit none integer, intent(in) :: im, levs, lm, lmk, lmp, n_var_lndp, & @@ -85,6 +87,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv_gf, me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & ntcw, ntiw, ntlnc, ntinc, & + ntrnc, ntsnc,ntccn, & ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & @@ -94,7 +97,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, & imp_physics_mg, imp_physics_wsm6, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & + imp_physics_nssl, & imp_physics_fer_hires, & yearlen, icloud @@ -102,8 +105,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & logical, intent(in) :: lsswr, lslwr, ltaerosol, lgfdlmprad, & uni_cld, effr_in, do_mynnedmf, & - lmfshal, lmfdeep2, pert_clds + lmfshal, lmfdeep2, pert_clds,first_time_step + logical, intent(in) :: nssl_ccn_on, nssl_invertccn real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd @@ -117,6 +121,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & cnvw_in, cnvc_in, & sppt_wts + real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs, aer_nm real(kind=kind_phys), dimension(:), intent(inout) :: coszen, coszdg @@ -173,6 +178,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + integer, intent(in) :: mpiroot ! Local variables integer :: ncndl @@ -193,6 +199,10 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(im,lm+LTP) :: & re_cloud, re_ice, re_snow, qv_mp, qc_mp, & qi_mp, qs_mp, nc_mp, ni_mp, nwfa + ! for NSSL MP + real(kind=kind_phys), dimension(im,lm+LTP) :: & + re_rain, qr_mp, ns_mp, nr_mp, nh_mp, vh_mp, cccn_mp,cccna_mp, nc_mp2 + real, allocatable :: an(:,:,:,:) ! temporary scalar array ! for F-A MP real(kind=kind_phys), dimension(im,lm+LTP) :: qc_save, qi_save, qs_save @@ -215,6 +225,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & its, ite, jts, jte, kts, kte real(kind=kind_phys) :: qvs + real (kind=kind_phys) :: sum1,sum2,max1,max2 ! !===> ... begin here ! @@ -673,6 +684,30 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo endif if_thompson + if (imp_physics == imp_physics_nssl) then + ! write(6,*) 'rrtm_pre: set qx_mp for NSSL',ntlnc,ntinc,ntsnc,ntrnc + do k=1,LMK +! IF ( me == mpiroot ) write(6,*) 'k,rho: ',k,rho(1,k) + do i=1,IM + qvs = qgrs(i,k,ntqv) + qv_mp (i,k) = qvs/(1.-qvs) + qc_mp (i,k) = tracer1(i,k,ntcw)/(1.-qvs) + qi_mp (i,k) = tracer1(i,k,ntiw)/(1.-qvs) + qs_mp (i,k) = tracer1(i,k,ntsw)/(1.-qvs) + qr_mp (i,k) = tracer1(i,k,ntrw)/(1.-qvs) + nc_mp (i,k) = tracer1(i,k,ntlnc)/(1.-qvs) + ni_mp (i,k) = tracer1(i,k,ntinc)/(1.-qvs) + ns_mp (i,k) = tracer1(i,k,ntsnc)/(1.-qvs) + nr_mp (i,k) = tracer1(i,k,ntrnc)/(1.-qvs) + IF ( nssl_ccn_on ) cccn_mp(i,k) = tracer1(i,k,ntccn)/(1.-qvs) + enddo + enddo +! write(6,*) 'rrtmg_pre: max qctrac,qc,qcphy,nctrac,ccw,ccwphy: ',maxval(qc_mp),maxval(qc), & +! maxval(qc_phys),maxval(nc_mp),maxval(ccw),maxval(ccw_phys) +! write(6,*) 'rrtmg_pre: max ni,ns,nr = ',maxval(ni_mp),maxval(ns_mp),maxval(nr_mp) + ! IF ( maxval(ni_mp) > 1.0 ) write(6,*) 'NI max = ',maxval(ni_mp) + ! IF ( maxval(qi_mp) > 0.01e-3 ) write(6,*) 'QI max = ',maxval(qi_mp) + endif endif do n=1,ncndl do k=1,LMK @@ -765,19 +800,112 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo endif - elseif (imp_physics == imp_physics_nssl2m .or. & - imp_physics == imp_physics_nssl2mccn ) then ! NSSL MP + elseif (imp_physics == imp_physics_nssl ) then ! NSSL MP cldcov = 0.0 if(effr_in) then +! if( kdt > 2 ) then +! IF ( .true. .or. maxval(nc_mp) >= 1.e-20 ) THEN do k=1,lm k1 = k + kd do i=1,im effrl(i,k1) = effrl_inout(i,k)! re_cloud (i,k) effri(i,k1) = effri_inout(i,k)! re_ice (i,k) - effrr(i,k1) = 1000. ! rrain_def=1000. + effrr(i,k1) = effrr_in(i,k) effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) enddo enddo + else + ! calculate radii here, but something is not right with incoming number concentrations + ! IF ( .true. .and. first_time_step ) THEN + IF ( ( maxval(qc_mp) > 1.e-11 .and. maxval(nc_mp) < 1.e-5 ) .or. & + ( maxval(qr_mp) > 1.e-11 .and. maxval(nr_mp) < 1.e-5 ) .or. & + ( maxval(qi_mp) > 1.e-11 .and. maxval(ni_mp) < 1.e-5 ) .or. & + ( maxval(qs_mp) > 1.e-11 .and. maxval(ns_mp) < 1.e-5 ) .or. kdt < 3 ) THEN +! ( maxval(qs_mp) > 1.e-11 .and. maxval(ns_mp) < 1.e-5 ) .or. .true. ) THEN + + allocate( an(im,1,lm,na) ) + an(:,:,:,:) = 0.0 + IF ( .true. .or. kdt <= 3 ) THEN + IF ( me == mpiroot ) THEN +! write(6,*) 'before calcn: max ccw = ',maxval(nc_mp),sum(nc_mp) + nc_mp2 = nc_mp + max1 = maxval(nc_mp) + sum1 = sum(nc_mp) + ENDIF +! IF ( maxval(nc_mp) < 1.e-20 ) THEN + call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & + & qcw=qc_mp,qci=qi_mp, qsw=qs_mp,qrw=qr_mp, & + & ccw=nc_mp,cci=ni_mp, csw=ns_mp,crw=nr_mp, & + & qv=qv_mp, invertccn_flag=nssl_invertccn ) +! ENDIF + IF ( .false. .and. me == mpiroot ) THEN + max2 = maxval(nc_mp) + sum2 = sum(nc_mp) + write(6,*) 'after calcn: max ccw = ',maxval(nc_mp),sum(nc_mp) + IF ( Abs(max1-max2) < 1.0 .and. Abs(sum2-sum1) > 1.0 ) THEN + DO k=1,lm + DO i=1,im + IF ( qc_mp(i,k) > 1.e-6 .and. (nc_mp2(i,k) /= nc_mp(i,k) ) ) THEN + write(6,*) 'i,k,qc,nc1,nc2 = ',i,k,qc_mp(i,k),nc_mp2(i,k),nc_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + ELSE +! call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & +! & qcw=qc_mp, & !qci=qi_mp, & ! qsw=qs_mp,qrw=qr_mp, & +! & ccw=nc_mp, & !cci=ni_mp, & ! csw=ns_mp,crw=nr_mp, & +! & cccn=cccn_mp,qv=qv_mp ) + call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & + & qci=qi_mp, qsw=qs_mp,qrw=qr_mp, & + & cci=ni_mp, csw=ns_mp,crw=nr_mp, & + & qv=qv_mp, invertccn_flag=nssl_invertccn ) + ENDIF + ! write(0,*) 'rrtmg_pre2: ni,ns,nr maxval: ',maxval(ni_mp),maxval(ns_mp),maxval(nr_mp),kdt + + deallocate( an ) + ENDIF + re_cloud = 0 + re_ice = 0 + re_snow = 0 + re_rain = 0 + call calc_eff_radius & + & (nx=im,ny=1,nz=lm,na=1,jyslab=1 & + & ,nor=0,norz=0 & + & ,t1=re_cloud,t2=re_ice,t3=re_snow,t4=re_rain & + & ,qcw=qc_mp,qci=qi_mp,qsw=qs_mp,qrw=qr_mp & + & ,ccw=nc_mp,cci=ni_mp,csw=ns_mp,crw=nr_mp & + & ,dn=rho ) + + do k=1,lm + k1 = k + kd + do i=1,im + IF ( .false. ) THEN + effrl(i,k1) = MAX(2.51E-6, MIN( re_cloud(i,k), 50.E-6))*1.e6 + effri(i,k1) = MAX(10.01E-6, MIN( re_ice(i,k), 125.E-6))*1.e6 + effrs(i,k1) = MAX(25.E-6, MIN( re_snow(i,k), 999.E-6))*1.e6 + ! effri(i,k1) = effri_inout(i,k)! re_ice (i,k) + ! effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) + ELSE + effrl(i,k1) = effrl_inout(i,k)! re_cloud (i,k) + effri(i,k1) = effri_inout(i,k)! re_ice (i,k) + effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) + ENDIF + effrr(i,k1) = MAX(25.E-6, MIN( re_rain(i,k), 2999.E-6))*1.e6 + enddo + enddo + + ! Update global arrays + do k=1,lm + k1 = k + kd + do i=1,im + effrl_inout(i,k) = effrl(i,k1) + effri_inout(i,k) = effri(i,k1) + effrs_inout(i,k) = effrs(i,k1) + enddo + enddo + endif elseif (imp_physics == imp_physics_thompson) then ! Thompson MP @@ -1032,9 +1160,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & effri_inout(:,:), effrs_inout(:,:), & dzb, xlat_d, julian, yearlen, & clouds,cldsa,mtopa,mbota, de_lgth, alpha) ! --- outputs - elseif( imp_physics == imp_physics_nssl2m & - .or. imp_physics == imp_physics_nssl2mccn & - ) then ! Thompson MP + + elseif ( imp_physics == imp_physics_nssl ) then ! NSSL MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv !-- MYNN PBL or convective GF @@ -1045,7 +1172,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo - ! --- use clduni as with the GFDL microphysics. + ! --- use clduni with the NSSL microphysics. ! --- make sure that effr_in=.true. in the input.nml! call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs xlat, xlon, slmsk, dz, delp, IM, LMK, LMP, & @@ -1068,10 +1195,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif ! MYNN PBL or GF - elseif(imp_physics == imp_physics_thompson & -! .or. imp_physics == imp_physics_nssl2m & -! .or. imp_physics == imp_physics_nssl2mccn & - ) then ! Thompson MP + elseif(imp_physics == imp_physics_thompson ) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv !-- MYNN PBL or convective GF diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 7825b3263..4a9a70efe 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -142,6 +142,22 @@ dimensions = () type = integer intent = in +[ntrnc] + standard_name = index_for_rain_number_concentration + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsnc] + standard_name = index_for_snow_number_concentration + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F [ntrw] standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array long_name = tracer index for rain water @@ -171,6 +187,14 @@ type = integer intent = in optional = F +[ntccn] + standard_name = index_for_cloud_condensation_nuclei_number_concentration + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F [ntwa] standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array long_name = tracer index for water friendly aerosol @@ -185,6 +209,22 @@ dimensions = () type = integer intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [ntclamt] standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array long_name = tracer index for cloud amount integer @@ -227,6 +267,14 @@ dimensions = () type = integer intent = in +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -250,7 +298,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -258,14 +306,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme @@ -1089,3 +1129,11 @@ dimensions = () type = integer intent = out +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 5aadec71b..2351dc992 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -520,7 +520,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, dtidx, ntlnc, & imp_physics_wsm6, imp_physics_fer_hires, prsi, ntinc, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & + imp_physics_nssl, & prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & work1, work2, kpbl, kinver, ras, me, save_lnc, save_inc, & ldiag3d, qdiag3d, index_of_process_conv_trans, & @@ -536,7 +536,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & integer, intent(in ) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, ntsw,& ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & - imp_physics_nssl2m, imp_physics_nssl2mccn ,me, index_of_process_conv_trans + imp_physics_nssl, me, index_of_process_conv_trans integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras @@ -668,7 +668,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & else save_qi(:,:) = clw(:,:,1) endif - else if (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + else if (imp_physics == imp_physics_nssl ) then do k=1,levs do i=1,im clw(i,k,1) = gq0(i,k,ntiw) ! ice @@ -712,10 +712,11 @@ end subroutine GFS_suite_interstitial_4_finalize !! subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_nssl2m,imp_physics_nssl2mccn, nssl_invertccn, otsptflag, ntracp1, & + imp_physics_nssl, nssl_invertccn, nssl_ccn_on, nssl_invertccn, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) + otsptflag, ntracp1, errmsg, errflg) use machine, only: kind_phys use module_mp_nssl_2mom, only: qccn @@ -730,10 +731,10 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr integer, intent(in) :: ntracp1 integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl2m, imp_physics_nssl2mccn + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl logical, intent(in) :: ltaerosol, convert_dry_rho - logical, intent(in) :: nssl_invertccn + logical, intent(in) :: nssl_ccn_on, nssl_invertccn real(kind=kind_phys), intent(in ) :: con_pi, dtf real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc @@ -866,14 +867,14 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo enddo - if ( .true. .and. ( imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) ) then + if ( .true. .and. ( imp_physics == imp_physics_nssl ) ) then liqm = con_pi/6.*1.e3*(40.e-6)**3 ! 4./3.*con_pi*1.e-12 icem = con_pi/6.*1.e3*(120.e-6)**3 ! 4./3.*con_pi*3.2768*1.e-14*890. ! qccn = nssl_cccn/1.225 do k=1,levs do i=1,im ! check number of available ccn - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN IF ( nssl_invertccn ) THEN xccn = qccn - gq0(i,k,ntccn) ELSE @@ -898,7 +899,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr IF ( xccn > 0.0 ) THEN xccw = Min( xccn, max(0.0, (clw(i,k,2)-save_qc(i,k))) / xcwmas ) gq0(i,k,ntlnc) = gq0(i,k,ntlnc) + xccw - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN IF ( nssl_invertccn ) THEN ! ccn are activated CCN, so add gq0(i,k,ntccn) = gq0(i,k,ntccn) + xccw diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 33f556193..9886a51a3 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1270,7 +1270,7 @@ dimensions = () type = integer intent = in -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -1278,14 +1278,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [prsi] standard_name = air_pressure_at_interface long_name = air pressure at model layer interfaces @@ -1686,7 +1678,12 @@ dimensions = () type = logical intent = in +<<<<<<< HEAD [imp_physics_nssl2m] +======= + optional = F +[imp_physics_nssl] +>>>>>>> 9d0fcbd1 ( - Changed from two imp_physics_nssl flags to a single one with second flag for nssl_ccn_on) standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -1694,12 +1691,12 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none dimensions = () - type = integer + type = logical intent = in optional = F [nssl_invertccn] diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 10c9ab99e..6beae0da2 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -27,8 +27,8 @@ end subroutine maximum_hourly_diagnostics_finalize #endif subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, & imp_physics_gfdl, imp_physics_thompson, & - imp_physics_fer_hires, imp_physics_nssl2m, & - imp_physics_nssl2mccn, con_g, phil, & + imp_physics_fer_hires, imp_physics_nssl, & + con_g, phil, & gt0, refl_10cm, refdmax, refdmax263k, u10m, v10m, & u10max, v10max, spd10max, pgr, t2m, q2m, t02max, & t02min, rh02max, rh02min, dtp, rain, pratemax, & @@ -38,7 +38,7 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, integer, intent(in) :: im, levs logical, intent(in) :: reset, lradar integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires, & - imp_physics_nssl2m, imp_physics_nssl2mccn + imp_physics_nssl real(kind_phys), intent(in ) :: con_g real(kind_phys), intent(in ) :: phil(:,:) real(kind_phys), intent(in ) :: gt0(:,:) @@ -76,13 +76,12 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, if (lradar .and. (imp_physics == imp_physics_gfdl .or. & imp_physics == imp_physics_thompson .or. & imp_physics == imp_physics_fer_hires .or. & - imp_physics == imp_physics_nssl2m .or. & - imp_physics == imp_physics_nssl2mccn)) then + imp_physics == imp_physics_nssl )) then allocate(refd(im)) allocate(refd263k(im)) call max_fields(phil,refl_10cm,con_g,im,levs,refd,gt0,refd263k) if (reset) then - IF ( imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) THEN + IF ( imp_physics == imp_physics_nssl ) THEN ! ERM: might not need this as a separate assignment do i=1,im refdmax(i) = 0. refdmax263k(i) = 0. diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 1a8407ac5..0cf6ed5b4 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -63,7 +63,7 @@ dimensions = () type = integer intent = in -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -71,14 +71,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index b6cc715fd..72575e60a 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -64,6 +64,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & qgrs_ozone, & & qgrs_water_aer_num_conc, & & qgrs_ice_aer_num_conc, & + & qgrs_cccn, & & prsl,exner, & & slmsk,tsurf,qsfc,ps, & & ust,ch,hflx,qflx,wspd,rb, & @@ -95,6 +96,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_ice_cloud, dqdt_ozone, & ! <=== ntiw, ntoz & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & ! <=== ntlnc, ntinc & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc, & ! <=== ntwa, ntia + & dqdt_cccn, & ! <=== ntccn & flag_for_pbl_generic_tend, & & dtend, dtidx, index_of_temperature, & & index_of_x_wind, index_of_y_wind, ntke, & @@ -108,7 +110,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & imp_physics_nssl2m, imp_physics_nssl2mccn, & + & imp_physics_nssl, nssl_ccn_on, & & ltaerosol, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: @@ -196,7 +198,7 @@ SUBROUTINE mynnedmf_wrapper_run( & ! NAMELIST OPTIONS (INPUT): LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect, ltaerosol, & lprnt, do_mynnsfclay, & - flag_for_pbl_generic_tend + flag_for_pbl_generic_tend, nssl_ccn_on INTEGER, INTENT(IN) :: & & bl_mynn_cloudpdf, & & bl_mynn_mixlength, & @@ -212,7 +214,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & grav_settling, & & imp_physics, imp_physics_wsm6, & & imp_physics_thompson, imp_physics_gfdl, & - & imp_physics_nssl2m, imp_physics_nssl2mccn + & imp_physics_nssl !TENDENCY DIAGNOSTICS real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) @@ -254,6 +256,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_water_vapor, dqdt_liquid_cloud, dqdt_ice_cloud, & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_ozone, dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc + real(kind=kind_phys), dimension(:,:), intent(inout) ::dqdt_cccn real(kind=kind_phys), dimension(:,:), intent(inout) :: & & qke, qke_adv, EL_PBL, Sh3D, & & qc_bl, qi_bl, cldfra_bl @@ -273,6 +276,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & qgrs_ozone, & & qgrs_water_aer_num_conc, & & qgrs_ice_aer_num_conc + real(kind=kind_phys), dimension(:,:), intent(in) ::qgrs_cccn real(kind=kind_phys), dimension(:,:), intent(out) :: & & Tsq, Qsq, Cov, exch_h, exch_m real(kind=kind_phys), dimension(:), intent(in) :: xmu @@ -400,14 +404,15 @@ SUBROUTINE mynnedmf_wrapper_run( & qnifa(i,k) = 0. enddo enddo - elseif (imp_physics == imp_physics_nssl2m .or. imp_physics == imp_physics_nssl2mccn ) then + elseif (imp_physics == imp_physics_nssl ) then ! NSSL FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. FLAG_QNC= .true. - FLAG_QNWFA= .false. + FLAG_QNWFA= nssl_ccn_on ! ERM: Perhaps could use this field for CCN field? FLAG_QNIFA= .false. + ! p_q vars not used? p_qc = 2 p_qr = 0 p_qi = 2 @@ -424,6 +429,9 @@ SUBROUTINE mynnedmf_wrapper_run( & qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) qnwfa(i,k) = 0. + IF ( nssl_ccn_on ) THEN + qnwfa(i,k) = qgrs_cccn(i,k) + ENDIF qnifa(i,k) = 0. enddo enddo @@ -872,6 +880,21 @@ SUBROUTINE mynnedmf_wrapper_run( & ! enddo !enddo endif !end thompson choice + elseif (imp_physics == imp_physics_nssl) then + ! NSSL + do k=1,levs + do i=1,im + dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) + dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) + IF ( nssl_ccn_on ) THEN ! + dqdt_cccn(i,k) = RQNWFABLTEN(i,k) + ENDIF + enddo + enddo + elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP do k=1,levs diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index ad877b837..8e60f953a 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -336,6 +336,15 @@ type = real kind = kind_phys intent = in +[qgrs_cccn] + standard_name = cloud_condensation_nuclei_number_concentration + long_name = number concentration of cloud condensation nuclei + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [prsl] standard_name = air_pressure long_name = mean layer pressure @@ -994,6 +1003,15 @@ type = real kind = kind_phys intent = inout +[dqdt_cccn] + standard_name = tendency_of_cloud_condensation_nuclei_number_concentration_due_to_model_physics + long_name = number concentration of cloud condensation nuclei tendency due to model physics + units = kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [flag_for_pbl_generic_tend] standard_name = flag_for_generic_tendency_due_to_planetary_boundary_layer long_name = true if GFS_PBL_generic should calculate tendencies @@ -1257,7 +1275,7 @@ dimensions = () type = integer intent = in -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -1265,12 +1283,12 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none dimensions = () - type = integer + type = logical intent = in optional = F [ltaerosol] diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 174cca092..0a8532de1 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1,7 +1,7 @@ !WRF:MODEL_LAYER:PHYSICS -! prepocessed on "Apr 18 2021" at "20:33:31" +! prepocessed on "Sep 30 2021" at "11:13:44" @@ -75,6 +75,32 @@ ! ! !--------------------------------------------------------------------- +! Sept. 2021: +! Fixes: +! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed density independent of size. Generally low reflectivity values as a result (no effect on microphysics) +! Other: +! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect) +! Reordered collection coefficients (dab1lh) to be consistent (no effect) +! Switched to full calculation of rain number loss via collection by graupel (chacr; to be consisted with collection by hail) (minor effects) +!--------------------------------------------------------------------- +! April 2021: +! Fixes: +! Fall speed air density factor limited to air density of 0.05 (for very high model top) to mitigate excessive fall speeds +! Fixed issue of spurious creation of large concentrations of very small droplets and transient large condensation (also increased minimum droplet size) +! Fixed issue of negligible "seed" values of graupel from Bigg freezing at relatively high temperatures (thanks to S. Lasher-Trapp) +! Minor bug fix in effective radius calculation of snow. (thanks to T. Iguchi) +! Updates: +! Enabled regeneration of CCN by droplet evaporation and background restore (default time constant of 3600s) +! Updated the routine that handles single-moment variables on the first time step. This sets a higher threshold for meaningful mixing ratios and sets a more realistic droplet concentration (also activating CCN as needed). +! Enabled radar reflectivity from cloud ice (new formulation) ( idbzci = 1 ) +! Added internal option for ice crystal nucleation by DeMott et al. (2010, PNAS) (inucopt=4) +! Allow greater fraction of hail to melt in one time step +! Reduced minimum number concentration from 1e-4 to 1e-8 (based on CAPS input) +! Added internal namelist for easier access to internal variables for development/testing and easier setup for ensemble microphysics diversity +! (namelist read is disabled by default) +! Increased resolution of lookup table for incomplete gamma functions +! +!--------------------------------------------------------------------- ! Sept. 2019: ! Bug fixes: ! - Effective radius calculation was only done at history times. Now every time step (though should be just before radiation is called) @@ -143,11 +169,13 @@ MODULE module_mp_nssl_2mom - + use physcons, only: con_pi, con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps IMPLICIT NONE public nssl_2mom_driver public nssl_2mom_init + public calc_eff_radius + public calcnfromq private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis private gamma_dp, gamxinfdp, gamma_dpr private delbk, delabk @@ -156,21 +184,13 @@ MODULE module_mp_nssl_2mom logical, private :: cleardiag = .false. PRIVATE -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) integer, parameter :: wrfchem_flag = 1 #else integer, parameter :: wrfchem_flag = 0 #endif LOGICAL, PRIVATE:: is_aerosol_aware = .false. -! From ThompsonAero: -! Declaration of constants for assumed CCN/IN aerosols when none in -! the input data. Look inside the init routine for modifications -! due to surface land-sea points or vegetation characteristics. - REAL, PARAMETER, PRIVATE:: naIN0 = 1.5E6 - REAL, PARAMETER, PRIVATE:: naIN1 = 0.5E6 - REAL, PARAMETER, PRIVATE:: naCCN0 = 300.0E6 - REAL, PARAMETER, PRIVATE:: naCCN1 = 50.0E6 logical, private :: turn_on_cin = .false. @@ -194,8 +214,7 @@ MODULE module_mp_nssl_2mom integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) ! =2 turn on for graupel density less than 300. only integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) - integer :: iusewetsnow = 1 ! =1 to turn on diagnosed bright band - + integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band ! microphysics real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params @@ -216,6 +235,7 @@ MODULE module_mp_nssl_2mom real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value real , public :: qccn ! ccn "mixing ratio" + real , private :: old_qccn = -1.0 integer, private :: iauttim = 1 ! 10-ice rain delay flag real , private :: auttim = 300. ! 10-ice rain delay time real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual @@ -226,10 +246,11 @@ MODULE module_mp_nssl_2mom #else logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state #endif + logical :: switchccn = .false. + real :: old_cccn = -1.0 logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) - ! sedimentation flags ! itfall -> 0 = 1st order fallout (other options removed) ! iscfall, infall -> fallout options for charge and number concentration, respectively @@ -237,9 +258,10 @@ MODULE module_mp_nssl_2mom integer, private :: itfall = 0 integer, private :: iscfall = 1 integer, private :: irfall = -1 - logical, private :: do_accurate_sedimentation = .false. ! if true, recalculate fall speeds on sub time steps; (more expensive) + logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive) ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) ! Mainly is an issue for small dz near the surface. + integer, private :: interval_sedi_vt = 1 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.) integer, private :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) ! 1 -> uses mass-weighted fallspeed for N ALWAYS ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS) @@ -277,11 +299,12 @@ MODULE module_mp_nssl_2mom real, private :: cimn = 1.0e3, cimx = 1.0e6 - + real , private :: rhofrz = 900 ! density of freezing drops real , private :: ifrzg = 1.0 ! fraction of frozen drops (Bigg freezing) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail real , private :: ifiacrg = 1.0 ! fraction of frozen drops (3-component freezing qiacr) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail real , private :: ifrzs = 1.0 ! fraction of small frozen drops going to snow. 1=freeze rain to snow, 0=freeze to cloud ice real , private :: ffrzs = 0.0 ! fraction of other initiated cloud ice going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + real , private :: f2h = 1.0 ! fraction of cloud ice conversion going to graupel (vs. frozen drops). For testing integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget) integer, private :: irimtim = 0 ! future use ! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds @@ -309,7 +332,7 @@ MODULE module_mp_nssl_2mom real :: renucfrac = 0.0 ! = 0 : cnuc = cwccn ! = 1 : cnuc = actual available CCN ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac - real :: ssf2kmax = 1.05 ! max value for ssf**cck in irenuc=4 + real :: ssf2kmax = 10. ! max value for ssf**cck in irenuc=4 or 5 real , private :: cck = 0.6 ! exponent in Twomey expression real , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation @@ -354,6 +377,7 @@ MODULE module_mp_nssl_2mom logical, private :: imeyers5 = .false. ! .false.=off, true=on for Meyers ice nucleation for temp > -5 C real , private :: dmincw = 15.0e-6 ! minimum droplet diameter for collection for iehw=3 integer, private :: iehw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data + integer, private :: iefw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data integer, private :: iehlw = 1 ! 0 -> ehlw=ehlw0; 1 -> old ehlw; 2 -> test ehlw with Mason table data ! For ehw/ehlw = 1, ehw0/ehlw0 act as maximum limit on collection efficiency (defaults are 1.0) integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) @@ -362,7 +386,9 @@ MODULE module_mp_nssl_2mom real , private :: ehw0 = 0.9 ! constant or max assumed graupel-droplet collection efficiency real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency real , private :: ehlw0 = 0.9 ! constant or max assumed hail-droplet collection efficiency + real , private :: efw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency + real :: efr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency real :: ehlr0 = 1.0 ! constant or max assumed hail-rain collection efficiency real , private :: exwmindiam = 0.0 ! minimum diameter of droplets for riming. If set > 0, will exclude that fraction of mass/number from accretion (idea from Furtado and Field 2017 JAS but also Fierro and Mansell 2017) @@ -430,6 +456,7 @@ MODULE module_mp_nssl_2mom ! and for ciacrf for iacr=4 real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail + integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail integer, private :: imltshddmr = 2 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail @@ -546,6 +573,7 @@ MODULE module_mp_nssl_2mom integer, private :: ibiggsnow = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction ! 3 = switch conversion over to snow for small frozen drops from both + real :: biggsnowdiam = -1.0 ! If >0, use for ibiggsnow threshold integer, private :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi) @@ -591,6 +619,7 @@ MODULE module_mp_nssl_2mom integer, private :: lis = 0 integer, private :: ls = 6 integer, private :: lh = 7 + integer, private :: lf = 0 integer, private :: lhl = 0 integer, private :: lccn = 9 ! 0 or 9, other indices adjusted accordingly @@ -604,7 +633,10 @@ MODULE module_mp_nssl_2mom integer, private :: lnis = 0 integer, private :: lns = 12 integer, private :: lnh = 13 + integer, private :: lnf = 0 integer, private :: lnhl = 0 + integer, private :: lnhf = 0 + integer, private :: lnhlf = 0 integer, private :: lss = 0 integer :: lvh = 15 @@ -624,6 +656,7 @@ MODULE module_mp_nssl_2mom ! liquid water fraction (not predicted here but tested for) integer :: lhw = 0 + integer :: lfw = 0 integer :: lsw = 0 integer :: lhlw = 0 integer :: lhwlg = 0 @@ -649,6 +682,7 @@ MODULE module_mp_nssl_2mom integer :: lscis = 0 integer :: lscs = 0 integer :: lsch = 0 + integer :: lscf = 0 integer :: lschl = 0 integer :: lscwi = 0 integer :: lscpi = 0 @@ -780,7 +814,6 @@ MODULE module_mp_nssl_2mom ! ! constants ! - real, parameter :: cp608 = 0.608 ! constant used in conversion of T to Tv real, parameter :: ar = 841.99666 ! rain terminal velocity power law coefficient (LFO) real, parameter :: br = 0.8 ! rain terminal velocity power law coefficient (LFO) real, parameter :: aradcw = -0.27544 ! @@ -797,11 +830,12 @@ MODULE module_mp_nssl_2mom ! new values for cs and ds real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient - real, parameter :: pi = 3.141592653589793 + real, parameter :: cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv + real, parameter :: pi = con_pi real, parameter :: piinv = 1./pi real, parameter :: pid4 = pi/4.0 - real, parameter :: gr = 9.8 + real, parameter :: gr = con_g ! ! max and min mean volumes @@ -865,13 +899,14 @@ MODULE module_mp_nssl_2mom real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation real, parameter :: cawbolton = 17.67 - real, parameter :: tfr = 273.15, tfrh = 233.15 + real, parameter :: tfr = con_t0c, tfrh = 233.15 - real, parameter :: cp = 1004.0, rd = 287.04 + real, parameter :: cp = con_cp, rd = con_rd, rw = con_rv + REAL, PRIVATE, parameter :: cpl = con_cliq ! 4190.0 + REAL, PRIVATE, parameter :: cpigb = con_csol ! 2106.0 real, parameter :: cpi = 1./cp real, parameter :: cap = rd/cp, poo = 1.0e+05 - real, parameter :: rw = 461.5 ! gas const. for water vapor real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity @@ -882,8 +917,6 @@ MODULE module_mp_nssl_2mom ! REAL, PRIVATE :: cv = cp - rd real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air REAL, PRIVATE, parameter :: cvv = 1408.5 - REAL, PRIVATE, parameter :: cpl = 4190.0 - REAL, PRIVATE, parameter :: cpigb = 2106.0 ! GHB real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) @@ -892,7 +925,7 @@ MODULE module_mp_nssl_2mom real :: cckm,ccne,ccnefac,cnexp,CCNE0 - integer :: na = 9 + integer, public :: na = 9 integer :: nxtra = 1 real gf4p5, gf4ds, gf4br real gsnow1, gsnow53, gsnow73 @@ -913,6 +946,10 @@ MODULE module_mp_nssl_2mom logical, parameter :: do_satadj_for_wrfchem = .true. +! Note to users: Many of these options are for development and not guaranteed to perform well. +! Some may not be functional depending on the version of the code. +! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions +! in that regard. NAMELIST /nssl_mp_params/ & ndebug, ncdebug,& iusewetgraupel, & @@ -932,6 +969,7 @@ MODULE module_mp_nssl_2mom icnuclimit, & irenuc, & restoreccn, ccntimeconst, cck, & + switchccn, old_cccn, & ciintmx, & itype1, itype2, & icenucopt, & @@ -1046,8 +1084,8 @@ MODULE module_mp_nssl_2mom delta_alphamlr, & iqvsopt, & maxsupersat, & - charging_border - + charging_border, & + do_accurate_sedimentation, interval_sedi_vt ! ##################################################################### ! ##################################################################### @@ -1123,7 +1161,9 @@ SUBROUTINE nssl_2mom_init( & & nssl_icdx, & & nssl_icdxhl, & & nssl_icefallfac, & - & nssl_snowfallfac & + & nssl_snowfallfac, & + & errmsg, errflg, & + & myrank, mpiroot & ) implicit none @@ -1137,8 +1177,11 @@ SUBROUTINE nssl_2mom_init( & & nssl_snowfallfac integer, intent(in), optional :: & & nssl_icdx, & - & nssl_icdxhl + & nssl_icdxhl, myrank, mpiroot + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg integer, intent(in) :: ims,ime, jms,jme, kms,kme real, intent(in), dimension(20) :: nssl_params @@ -1146,6 +1189,10 @@ SUBROUTINE nssl_2mom_init( & integer, intent(in) :: ipctmp,mixphase,ihvol logical, optional, intent(in) :: idoniconlytmp + + logical :: wrote_namelist = .false. + logical :: wrf_dm_on_monitor + double precision :: arg real :: temq integer :: igam @@ -1160,6 +1207,8 @@ SUBROUTINE nssl_2mom_init( & integer :: istat + errmsg = '' + errflg = 0 turn_on_ccna = .false. turn_on_cina = .false. ! @@ -1199,6 +1248,25 @@ SUBROUTINE nssl_2mom_init( & + IF ( .true. ) THEN ! set to true to enable internal namelist read + open(15,file='input.nml',status='old',form='formatted',action='read') + rewind(15) + read(15,NML=nssl_mp_params,iostat=istat) + close(15) + IF ( present ( myrank ) .and. present ( mpiroot ) ) THEN + IF ( myrank == mpiroot ) THEN + IF ( istat /= 0 ) THEN + write(0,*) 'READ_NAMELIST: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + ENDIF + +! write(0,*) 'iusewetsnow = ',iusewetsnow + + open(15,file='nssl_mp_params.out',status='unknown',form='formatted') + write(15,NML=nssl_mp_params) + close(15) + ENDIF + ENDIF + ENDIF @@ -1450,8 +1518,9 @@ SUBROUTINE nssl_2mom_init( & ! ltmp = lhlw ENDIF ELSEIF ( ipconc >= 6 ) THEN - write(0,*) 'NSSL microphysics has not been compiled for 3-moment. Sorry.' - STOP + errmsg = 'NSSL microphysics has not been compiled for 3-moment. Sorry.' + errflg = 1 + return lccn = lhab+1 ! 9 lnc = lhab+2 ! 10 lnr = lhab+3 ! 11 @@ -1752,6 +1821,11 @@ SUBROUTINE nssl_2mom_init( & IF ( lzr > 0 ) irfall = 0 qccn = ccn/rho00 + IF ( old_cccn > 0.0 ) THEN + old_qccn = old_cccn/rho00 + ELSE + old_qccn = qccn + ENDIF ! xvcmx = (4./3.)*pi*xcradmx**3 ! set max rain diameter @@ -1956,12 +2030,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & SR,HAILNC, HAILNCV, & tkediss, & - re_cloud, re_ice, re_snow, & - has_reqc, has_reqi, has_reqs, & + re_cloud, re_ice, re_snow, re_rain, & + has_reqc, has_reqi, has_reqs, has_reqr, & rainncw2, rainnci2, & dbz, vzf,compdbz, & rscghis_2d,rscghis_2dp,rscghis_2dn, & scr,scw,sci,scs,sch,schl,sctot, & + elec_physics, & induc,elec,scion,sciona, & noninduc,noninducp,noninducn, & pcc2, pre2, depsubr, & @@ -1978,13 +2053,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & ipelectmp, & diagflag,ke_diag, & - NWFA, f_qnwfa, & - NIFA, f_qnifa, & - nwfa2d, & - qnn2d, & + errmsg, errflg, & nssl_progn, & ! wrf-chem ! 20130903 acd_mb_washout start - rainprod, evapprod, & ! wrf-chem + wetscav_on, rainprod, evapprod, & ! wrf-chem ! 20130903 acd_mb_washout end cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added ids,ide, jds,jde, kds,kde, & ! domain dims @@ -1993,21 +2065,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw -#if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) -#define MPI - USE module_dm, ONLY : & - local_communicator, mytask -! keep a spacing line here to keep Apple cpp from adding a space in front of the endif -#endif - implicit none -#if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) || defined(MPI) - INCLUDE 'mpif.h' -#else - integer :: mytask = 0 - -#endif !Subroutine arguments: @@ -2029,6 +2088,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) rscghis_2dn ! 2D accumulation arrays for vertically-integrated charging rate (negative only) ! real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d + integer, optional, intent(in) :: elec_physics real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & @@ -2061,11 +2121,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: & - re_cloud, re_ice, re_snow, nwfa, nifa - real, dimension(ims:ime, jms:jme), intent(in), optional :: nwfa2d,qnn2d + integer, parameter :: nproc = 1 + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, re_rain REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss - INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr real, dimension(ims:ime, jms:jme), intent(out), optional :: & rainncw2, rainnci2 ! liquid rain, ice, accumulation rates real, optional, intent(in) :: dx,dy @@ -2074,12 +2133,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina integer, optional, intent(in) :: ipelectmp, ke_diag + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem - LOGICAL, INTENT(IN), OPTIONAL :: f_qnifa , f_qnwfa ! flags for Thompson aero ! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop LOGICAL :: flag_qndrop ! wrf-chem LOGICAL :: flag_qnifa , flag_qnwfa + logical :: flag real :: cinchange, t7max,testmax,wmax ! 20130903 acd_ck_washout start @@ -2094,6 +2157,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! mu : air mass in column REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: qrcuten, qscuten, qicuten, qccuten INTEGER, optional, intent(in) :: cu_used + LOGICAL, optional, intent(in) :: wetscav_on ! ! local variables @@ -2106,6 +2170,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d real, dimension(its:ite, 1, na) :: xfall + real, dimension(kts:kte, nproc) :: thproclocal integer, parameter :: nor = 0, ng = 0 integer :: nx,ny,nz integer ix,jy,kz,i,j,k,il,n @@ -2118,6 +2183,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real :: dbzmx,refl integer :: vzflag0 = 0 logical :: makediag + real :: dx1,dy1 real, parameter :: cnin20 = 1.0e3 real, parameter :: cnin10 = 5.0e1 real, parameter :: cnin1a = 4.5 @@ -2139,10 +2205,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw double precision :: timevtcalc,timesetvt logical :: f_cnatmp, f_cinatmp + logical :: has_wetscav integer :: kediagloc integer :: iunit + real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot + real :: fach(kts:kte) + #ifdef MPI #if defined(MPI) @@ -2155,6 +2225,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ------------------------------------------------------------------- + errmsg = '' + errflg = 0 rdt = 1.0/dtp @@ -2166,8 +2238,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn - IF ( PRESENT ( f_qnifa ) ) flag_qnifa = f_qnifa - IF ( PRESENT ( f_qnwfa ) ) flag_qnwfa = f_qnwfa @@ -2202,6 +2272,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ENDDO ! ENDIF + IF ( present( dx ) .and. present( dy ) ) THEN + dx1 = dx + dy1 = dy + ELSE + dx1 = 1.0 + dy1 = 1.0 + ENDIF + makediag = .true. IF ( present( diagflag ) ) THEN @@ -2218,10 +2296,26 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( .not. present( cn ) ) THEN renucfrac = 1.0 ENDIF + + + + IF ( switchccn .and. lccna > 1 .and. .not. invertccn) THEN + ! hack to switch from ccn to ccna from a restart + + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cn(ix,kz,jy) = Max( 0.0, old_qccn - cn(ix,kz,jy) ) + ENDDO + ENDDO + ENDDO + switchccn = .false. + ENDIF ! ENDIF ! itimestep == 1 + ! sedimentation settings infdo = 2 @@ -2307,7 +2401,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) an(ix,1,kz,lhl) = qhl(ix,kz,jy) IF ( lccn > 1 ) THEN IF ( is_aerosol_aware .and. flag_qnwfa ) THEN - an(ix,1,kz,lccn) = nwfa(ix,kz,jy) + ! ELSEIF ( present( cn ) ) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN an(ix,1,kz,lccna) = cn(ix,kz,jy) @@ -2337,10 +2431,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF - IF ( lcin > 1 .and. flag_qnifa ) THEN - an(ix,1,kz,lcin) = nifa(ix,kz,jy) - ENDIF - IF ( ipconc >= 5 ) THEN an(ix,1,kz,lnc) = ccw(ix,kz,jy) IF ( constccw > 0.0 ) THEN @@ -2480,9 +2570,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! ix ENDDO ! kz + has_wetscav = .false. IF ( wrfchem_flag > 0 ) THEN - IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 - IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( wetscav_on ) ) THEN + has_wetscav = wetscav_on + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF + ENDIF ENDIF @@ -2509,6 +2605,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( itimestep == 1 .and. ipconc > 0 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) ENDIF +! IF ( itimestep == 3 .and. ipconc > 0 ) THEN +! call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) +! ENDIF ! #endif IF ( present(cu_used) .and. & @@ -2565,7 +2664,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) - IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + IF ( present( GRPLNCV ) ) THEN + IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) + ELSE + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + ENDIF + ENDIF RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) @@ -2577,8 +2682,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw !#endif HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) - ELSEIF ( present( GRPLNCV ) ) THEN - GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) +! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel +! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) ENDIF ENDIF IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) @@ -2600,7 +2705,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! IF ( isedonly /= 2 ) THEN - IF ( .true. ) THEN call nssl_2mom_gs & & (nx,ny,nz,na,jy & & ,nor,nor & @@ -2614,12 +2718,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,dbz2d,tke2d, & + & thproclocal,nproc,dx1,dy1, & & timevtcalc,axtra2d, makediag & - & ,rainprod2d, evapprod2d & - & ,elec2,its,ids,ide,jds,jde & + & ,has_wetscav, rainprod2d, evapprod2d & + & ,errmsg,errflg & + & ,elec2,its,ids,ide,jds,jde & & ) - ENDIF - @@ -2635,6 +2739,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,t0,t9 & & ,an,dn1,t77 & & ,pn,wn & + & ,thproclocal,nproc,dx1,dy1,dz2d & & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) @@ -2642,6 +2747,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF + IF ( present( pcc2 ) .and. makediag ) THEN DO kz = kts,kte DO ix = its,ite @@ -2703,14 +2809,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw t1(ix,1,kz) = 2.51E-6 t2(ix,1,kz) = 10.01E-6 t3(ix,1,kz) = 25.E-6 + t4(ix,1,kz) = 50.e-6 ENDDO ENDDO + call calc_eff_radius & & (nx,ny,nz,na,jy & & ,nor,nor & - & ,t1,t2,t3 & - & ,an,dn1 ) + & ,t1=t1,t2=t2,t3=t3,t4=t4 & + & ,an=an,dn=dn1 ) DO kz = kts,kte DO ix = its,ite @@ -2721,6 +2829,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) ENDDO ENDDO + + IF ( present(has_reqr) .and. present( re_rain ) ) THEN + IF ( has_reqr /= 0 ) THEN + re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t3(ix,1,kz), 2999.E-6)) + ENDIF + ENDIF ENDIF ENDIF @@ -2760,9 +2874,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN - nwfa(ix,kz,jy) = an(ix,1,kz,lccn) -! nwfa(ix,kz,jy) = Min(1.5e9, nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp) - IF ( kz == 1 ) nwfa(ix,kz,jy) = nwfa(ix,kz,jy) + nwfa2d(ix,jy)*dtp + ! not used here ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN IF ( lccna > 1 .and. .not. present( cna ) ) THEN cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) @@ -2782,10 +2894,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF - IF ( lcin > 1 .and. flag_qnifa ) THEN - nifa(ix,kz,jy) = an(ix,1,kz,lcin) - ENDIF - IF ( ipconc >= 5 ) THEN ccw(ix,kz,jy) = an(ix,1,kz,lnc) @@ -2802,12 +2910,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lvh > 0 ) vhw(ix,kz,jy) = an(ix,1,kz,lvh) IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl) -#ifdef WRF_CHEM - IF ( wrfchem_flag > 0 ) THEN +#if ( WRF_CHEM == 1 ) + IF ( has_wetscav ) THEN IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) ENDIF #endif + ENDDO ENDDO @@ -3677,7 +3786,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO n = 1,ndfall - IF ( do_accurate_sedimentation .and. n .ge. 2 ) THEN + IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN ! ! zero the precip flux arrays (2d) ! @@ -4279,13 +4388,17 @@ END subroutine calcnfromz1d ! ############################################################################## ! ! Subroutine to calculate number concentrations from initial state that has only mixing ratio. -! N will be in #/kg, NOT #/m^3, since sedimentation is done next. -! +! Output N will be in #/m^3 in 'an' array, since sedimentation is done next. +! Output ccw,cci etc. will be in #/kg ! ! 10.27.2015: Added hail calculation ! - subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) + subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & + & qcw,qci,qsw,qrw,qhw,qhl, & + & ccw,cci,csw,crw,chw,chl, & + & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin ) + implicit none @@ -4295,6 +4408,12 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) real dn(nx,nz+1) ! air density + + real, optional, dimension(nx,nz), intent(inout) :: qcw,qci,qsw,qrw,qhw,qhl, & + ccw,cci,csw,crw,chw,chl, & + cccn,cccna,vhw,vhl,qv, spechum + logical, optional, intent(in) :: invertccn_flag + real, optional :: cwmasin integer ixe,kze real alpha @@ -4306,7 +4425,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) integer ix,jy,kz - double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 @@ -4319,11 +4438,24 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx) real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet - real xv,xdn + real xv,xdn,cwmasinv integer :: ndbz, nmwgt, nnwgt, nwlessthanz + double precision :: mixconv, mixconvqv, qsmax,qsmax2,qsmax3,qsmax4 + logical :: invertccn_local ! ------------------------------------------------------------------ + IF ( present( invertccn_flag ) ) THEN + invertccn_local = invertccn_flag + ELSE + invertccn_local = .false. + ENDIF + + IF ( present( cwmasin ) ) THEN + cwmasinv = 1.0/cwmasin + ELSE + cwmasinv = 1.0/cwmas09 + ENDIF jy = 1 @@ -4342,18 +4474,59 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF g1s = (snu+2.0)/(snu+1.0) - + qsmax = 0 + qsmax2 = 0 + qsmax3 = 0 + qsmax4 = 0 +! IF ( .not. present( qcw ) ) THEN DO kz = 1,nz DO ix = 1,nx ! ixcol +! qv_mp = spechum/(1.0_kind_phys-spechum) +! IF ( convertdry ) THEN +! qc_mp = qc/(1.0_kind_phys-spechum) + mixconv = 1 + IF ( present( spechum ) ) THEN ! convert to "dry" mixing ratios + an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconv = 1.0d0/(1.0d0 - spechum(ix,kz)) + ELSE + mixconv = 1.0d0 + ENDIF + IF ( present( qv ) ) an(ix,jy,kz,lv) = qv(ix,kz) ! assume qv is "dry" mixing ratio if passed in + IF ( present( qcw ) ) an(ix,jy,kz,lc) = qcw(ix,kz)*mixconv + IF ( present( qrw ) ) an(ix,jy,kz,lr) = qrw(ix,kz)*mixconv + IF ( present( qci ) ) an(ix,jy,kz,li) = qci(ix,kz)*mixconv + IF ( present( qsw ) ) THEN + an(ix,jy,kz,ls) = qsw(ix,kz)*mixconv +! qsmax = Max( qsmax, qsw(ix,kz) ) +! qsmax2 = Max( qsmax2, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) an(ix,jy,kz,lh) = qhw(ix,kz)*mixconv + IF ( lhl > 1 .and. present( qhl ) ) an(ix,jy,kz,lhl) = qhl(ix,kz)*mixconv + IF ( present( ccw ) ) an(ix,jy,kz,lnc) = ccw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( crw ) ) an(ix,jy,kz,lnr) = crw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( cci ) ) an(ix,jy,kz,lni) = cci(ix,kz)*mixconv*dn(ix,kz) + IF ( present( csw ) ) an(ix,jy,kz,lns) = csw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( chw ) ) an(ix,jy,kz,lnh) = chw(ix,kz)*mixconv*dn(ix,kz) + IF ( lhl > 1 .and. present( chl ) ) an(ix,jy,kz,lnhl) = chl(ix,kz)*mixconv*dn(ix,kz) + IF ( lvh > 1 .and. present( vhw ) ) an(ix,jy,kz,lvh) = vhw(ix,kz)*mixconv + IF ( lvhl > 1 .and. present( vhl ) ) an(ix,jy,kz,lvhl) = vhl(ix,kz)*mixconv + IF ( lccn > 1 .and. present( cccn ) ) an(ix,jy,kz,lccn) = cccn(ix,kz)*mixconv*dn(ix,kz) + IF ( lccna > 1 .and. present( cccna ) ) an(ix,jy,kz,lccna) = cccna(ix,kz)*mixconv + dninv = 1./dn(ix,kz) +! IF ( .not. present( qcw ) ) THEN ! Cloud droplets IF ( lnc > 1 ) THEN IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN - an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)/cwmas09 )*dn(ix,kz) + an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)*cwmasinv )*dn(ix,kz) + + IF ( invertccn_local ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + an(ix,jy,kz,lnc) + ELSE IF ( lccn > 1 .and. lccna < 1 ) THEN an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc) @@ -4361,6 +4534,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) IF ( lccna > 1 ) THEN an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) ENDIF + ENDIF ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. & ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN @@ -4500,9 +4674,56 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF ENDIF - + + +! ENDIF + +! spechum = qv_mp/(1.0_kind_phys+qv_mp) +! IF ( convertdry ) THEN +! qc = qc_mp/(1.0_kind_phys+qv_mp) + mixconvqv = 1 + IF ( present( spechum ) ) THEN ! convert back to "dry+vapor" mixing ratios + !an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconvqv = 1.0d0/(1.0d0 + an(ix,jy,kz,lv)) + spechum(ix,kz) = an(ix,jy,kz,lv)*mixconvqv + ELSE + mixconvqv = 1.0d0 + ENDIF + + IF ( present( qv ) ) qv(ix,kz) = an(ix,jy,kz,lv) + IF ( present( qcw ) ) qcw(ix,kz) = an(ix,jy,kz,lc)*mixconvqv + IF ( present( qrw ) ) qrw(ix,kz) = an(ix,jy,kz,lr)*mixconvqv + IF ( present( qci ) ) qci(ix,kz) = an(ix,jy,kz,li)*mixconvqv + IF ( present( qsw ) ) THEN + qsw(ix,kz) = an(ix,jy,kz,ls)*mixconvqv +! qsmax3 = Max( qsmax3, qsw(ix,kz) ) +! qsmax4 = Max( qsmax4, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) qhw(ix,kz) = an(ix,jy,kz,lh)*mixconvqv + IF ( lhl > 1 .and. present( qhl ) ) qhl(ix,kz) = an(ix,jy,kz,lhl)*mixconvqv + IF ( present( ccw ) ) ccw(ix,kz) = an(ix,jy,kz,lnc)*mixconvqv*dninv + IF ( present( crw ) ) crw(ix,kz) = an(ix,jy,kz,lnr)*mixconvqv*dninv + IF ( present( cci ) ) cci(ix,kz) = an(ix,jy,kz,lni)*mixconvqv*dninv + IF ( present( csw ) ) csw(ix,kz) = an(ix,jy,kz,lns)*mixconvqv*dninv + IF ( present( chw ) ) chw(ix,kz) = an(ix,jy,kz,lnh)*mixconvqv*dninv + IF ( lhl > 1 .and. present( chl ) ) chl(ix,kz) = an(ix,jy,kz,lnhl)*mixconvqv*dninv + IF ( lvh > 1 .and. present( vhw ) ) vhw(ix,kz) = an(ix,jy,kz,lvh)*mixconvqv + IF ( lvhl > 1 .and. present( vhl ) ) vhl(ix,kz) = an(ix,jy,kz,lvhl)*mixconvqv + IF ( lccn > 1 .and. present( cccn ) ) cccn(ix,kz) = an(ix,jy,kz,lccn)*mixconvqv*dninv + IF ( lccna > 1 .and. present( cccna ) ) cccna(ix,kz) = an(ix,jy,kz,lccna)*mixconvqv + + ENDDO ! ix ENDDO ! kz +! ELSE +! write(0,*) 'calcnfromq: lv = ',lv,lc,lr,li,ls,lh,lvh,lhl,lccn,lccna +! write(0,*) 'calcnfromq: nx,ny,nz,na = ',nx,ny,nz,na +! +! ENDIF + +! IF ( present( qsw ) ) THEN +! write(0,*) 'calcnfromq: qsmax = ',qsmax,qsmax2,qsmax3,qsmax4 +! ENDIF RETURN @@ -4710,7 +4931,9 @@ END subroutine calcnfromcuten SUBROUTINE calc_eff_radius & & (nx,ny,nz,na,jyslab & & ,nor,norz & - & ,t1,t2,t3 & + & ,t1,t2,t3,t4 & + & ,qcw,qci,qsw,qrw & + & ,ccw,cci,csw,crw & & ,an,dn ) implicit none @@ -4726,13 +4949,14 @@ SUBROUTINE calc_eff_radius & ! external temporary arrays ! - real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - + real,optional :: t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real, optional, dimension(nx,nz) :: qcw,qci,qsw,qrw,ccw,cci,csw,crw @@ -4768,8 +4992,9 @@ SUBROUTINE calc_eff_radius & real :: xdia(ngs,lc:lhab,3) real :: alpha(ngs,lc:lhab) - real :: gamc1,gamc2,gami1,gami2,gams1,gams2, factor_c, factor_i, factor_s - real :: lam_c, lam_i, lam_s + real :: gamc1,gamc2,gami1,gami2,gams1,gams2,gamr1,gamr2 + real :: factor_c, factor_i, factor_s, factor_r + real :: lam_c, lam_i, lam_s, lam_r integer :: il @@ -4796,11 +5021,21 @@ SUBROUTINE calc_eff_radius & gami2 = 1. ! Gamma[1 + alphac] gams1 = Gamma_sp(2. + snu) gams2 = Gamma_sp(1. + snu) + gamr1 = Gamma_sp(2. + rnu) + gamr2 = Gamma_sp(1. + rnu) factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu) factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu) factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu) + IF ( present(t4) ) THEN + IF ( imurain == 3 ) THEN + factor_r = (1. + rnu)*Gamma_sp(1. + rnu)/Gamma_sp(5./3. + rnu) + ELSE + factor_r = ((Pi*(alphar+3.)*(alphar+1.)*(alphar+1.))/6.)**(1./3.) + ENDIF + ENDIF + ! ! jy = 1 ! working on a 2d slab !! VERY IMPORTANT: SET jgs = jy @@ -4812,29 +5047,57 @@ SUBROUTINE calc_eff_radius & DO ix = 1,nx ! ixcol rho0(mgs) = dn(ix,jy,kz) + IF ( present( an ) ) THEN DO il = lc,ls qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) ENDDO + ELSE + qx(mgs,:) = 0.0 + cx(mgs,:) = 0.0 + IF ( present(qcw) ) qx(mgs,lc) = qcw(ix,kz) + IF ( present(qci) ) qx(mgs,li) = qci(ix,kz) + IF ( present(qsw) ) qx(mgs,ls) = qsw(ix,kz) + IF ( present(qrw) ) qx(mgs,lr) = qrw(ix,kz) + IF ( present(ccw) ) cx(mgs,lc) = ccw(ix,kz)*rho0(mgs) + IF ( present(cci) ) cx(mgs,li) = cci(ix,kz)*rho0(mgs) + IF ( present(csw) ) cx(mgs,ls) = csw(ix,kz)*rho0(mgs) + IF ( present(crw) ) cx(mgs,lr) = crw(ix,kz)*rho0(mgs) - IF ( qx(mgs,lc) > qxmin(lc) ) THEN + ENDIF + + IF ( present( t1 ) .and. qx(mgs,lc) > qxmin(lc) .and. cx(mgs,lc) > cxmin ) THEN ! Lambda for cloud droplets lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) t1(ix,jy,kz) = 0.5*factor_c/lam_c ENDIF - IF ( qx(mgs,li) > qxmin(li) ) THEN + IF ( present( t2 ) .and. qx(mgs,li) > qxmin(li) .and. cx(mgs,li) > cxmin ) THEN ! Lambda for cloud ice lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) t2(ix,jy,kz) = 0.5*factor_i/lam_i ENDIF - IF ( qx(mgs,ls) > qxmin(ls) ) THEN + IF ( present( t3 ) .and. qx(mgs,ls) > qxmin(ls) .and. cx(mgs,ls) > cxmin ) THEN ! Lambda for snow lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.) t3(ix,jy,kz) = 0.5*factor_s/lam_s ENDIF + IF ( present( t4 ) .and. present(qrw) .and. present(crw) ) THEN + IF ( qx(mgs,lr) > Max(1.e-8,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN + IF ( imurain == 1 ) THEN ! gamma-diameter +! Lambda for rain + lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.) + t4(ix,jy,kz) = 0.5*(alphar+3.)/lam_r + ELSE ! gamma-volume +! Lambda for rain + lam_r = ((cx(mgs,lr)*(Pi/6.)*xdn0(lr)*Gamr1)/(qx(mgs,lr)*rho0(mgs)*Gamr2))**(1./3.) + t4(ix,jy,kz) = 0.5*factor_r/lam_r + ENDIF + ENDIF + ENDIF + ENDDO ! ix ENDDO ! kz @@ -5009,7 +5272,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & - & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + & itype1a,itype2a,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) implicit none @@ -5047,8 +5311,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & integer, intent (in) :: itype1a,itype2a,infdo integer, intent (in) :: ildo ! which species to do, or all if ildo=0 - real :: axh(ngs),bxh(ngs) - real :: axhl(ngs),bxhl(ngs) + real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) +!! real :: axh(ngs),bxh(ngs) +! real :: axhl(ngs),bxhl(ngs) ! Local vars @@ -5955,17 +6220,17 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) ) IF ( indxr < ngdnmm ) THEN - axh(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) - bxh(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + axx(mgs,lh) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxx(mgs,lh) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) ELSE - axh(mgs) = mmgraupvt(indxr,2) - bxh(mgs) = mmgraupvt(indxr,3) + axx(mgs,lh) = mmgraupvt(indxr,2) + bxx(mgs,lh) = mmgraupvt(indxr,3) ENDIF - aax = axh(mgs) - bbx = bxh(mgs) + aax = axx(mgs,lh) + bbx = bxx(mgs,lh) cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) @@ -5979,12 +6244,12 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & cdxgs(mgs,lh) = cd IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN -! axh(mgs) = (gf4p5/6.0)* & +! axx(mgs,lh) = (gf4p5/6.0)* & ! & Sqrt( (xdn(mgs,lh)*4.0*gr) / & ! & (3.0*cd*rho0(mgs)) ) - axh(mgs) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) - bxh(mgs) = 0.5 - vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axh(mgs) * Sqrt(xdia(mgs,lh,1)) + axx(mgs,lh) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + bxx(mgs,lh) = 0.5 + vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lh) * Sqrt(xdia(mgs,lh,1)) ! vtxbar(mgs,lh,1) = (gf4p5/6.0)* & ! & Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) / & ! & (3.0*cd*rho0(mgs)) ) @@ -6006,13 +6271,13 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & IF ( icdx > 0 .and. icdx /= 6) THEN aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) vtxbar(mgs,lh,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y - axh(mgs) = aax - bxh(mgs) = bbx + axx(mgs,lh) = aax + bxx(mgs,lh) = bbx ELSEIF (icdx == 6 ) THEN vtxbar(mgs,lh,1) = rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y ELSE ! icdx < 0 - axh(mgs) = ax(lh) - bxh(mgs) = bx(lh) + axx(mgs,lh) = ax(lh) + bxx(mgs,lh) = bx(lh) vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y ENDIF @@ -6059,17 +6324,17 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) ) IF ( indxr < ngdnmm ) THEN - axhl(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) - bxhl(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + axx(mgs,lhl) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxx(mgs,lhl) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) ELSE - axhl(mgs) = mmgraupvt(indxr,2) - bxhl(mgs) = mmgraupvt(indxr,3) + axx(mgs,lhl) = mmgraupvt(indxr,2) + bxx(mgs,lhl) = mmgraupvt(indxr,3) ENDIF - aax = axhl(mgs) - bbx = bxhl(mgs) + aax = axx(mgs,lhl) + bbx = bxx(mgs,lhl) cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) @@ -6083,12 +6348,12 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & cdxgs(mgs,lhl) = cd IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 .and. icdxhl /= 6) THEN -! axhl(mgs) = (gf4p5/6.0)* & +! axx(mgs,lhl) = (gf4p5/6.0)* & ! & Sqrt( (xdn(mgs,lhl)*4.0*gr) / & ! & (3.0*cd*rho0(mgs)) ) - axhl(mgs) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) - bxhl(mgs) = 0.5 - vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axhl(mgs) * Sqrt(xdia(mgs,lhl,1)) + axx(mgs,lhl) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + bxx(mgs,lhl) = 0.5 + vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lhl) * Sqrt(xdia(mgs,lhl,1)) ELSE IF ( icdxhl /= 6 ) bbx = bx(lhl) tmp = 4. + alpha(mgs,lhl) + bbx @@ -6104,13 +6369,13 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & IF ( icdxhl > 0 .and. icdxhl /= 6) THEN aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y - axhl(mgs) = aax - bxhl(mgs) = bbx + axx(mgs,lhl) = aax + bxx(mgs,lhl) = bbx ELSEIF ( icdxhl == 6 ) THEN vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y ELSE - axhl(mgs) = ax(lhl) - bxhl(mgs) = bx(lhl) + axx(mgs,lhl) = ax(lhl) + bxx(mgs,lhl) = bx(lhl) vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y ENDIF @@ -6176,8 +6441,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSEIF ( icdx .eq. 5 ) THEN cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) - aax = axh(mgs) - bbx = bxh(mgs) + aax = axx(mgs,lh) + bbx = bxx(mgs,lh) ELSEIF ( icdx <= 0 ) THEN ! aax = ax(lh) bbx = bx(lh) @@ -6198,8 +6463,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) - aax = axhl(mgs) - bbx = bxhl(mgs) + aax = axx(mgs,lhl) + bbx = bxx(mgs,lhl) ENDIF ENDIF ! } @@ -6355,7 +6620,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,lh,1) = graupelfallfac*vtxbar(mgs,lh,1) vtxbar(mgs,lh,2) = graupelfallfac*vtxbar(mgs,lh,2) vtxbar(mgs,lh,3) = graupelfallfac*vtxbar(mgs,lh,3) - axh(mgs) = graupelfallfac*axh(mgs) + axx(mgs,lh) = graupelfallfac*axx(mgs,lh) ENDDO ENDIF @@ -6364,7 +6629,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,lhl,1) = hailfallfac*vtxbar(mgs,lhl,1) vtxbar(mgs,lhl,2) = hailfallfac*vtxbar(mgs,lhl,2) vtxbar(mgs,lhl,3) = hailfallfac*vtxbar(mgs,lhl,3) - axhl(mgs) = hailfallfac*axhl(mgs) + axx(mgs,lhl) = hailfallfac*axx(mgs,lhl) ENDDO ENDIF @@ -6454,7 +6719,8 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & real :: zx(ngs,lr:lhab) real xdnmx(lc:lhab), xdnmn(lc:lhab) - real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + real :: axx(ngs,lh:lhab), bxx(ngs,lh:lhab) +! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) ! ! drag coefficients @@ -6799,7 +7065,8 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) @@ -7518,13 +7785,25 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN - IF ( .true. ) THEN -! IF ( qxw > qsmin ) THEN ! old version + ! IF ( .true. ) THEN + IF ( qxw > qsmin ) THEN ! old version ! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & ! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size + ! p = 0.106214 for m = p v^(2/3) + dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) + IF ( .true. .or. dnsnow < 900. ) THEN + gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + & + & (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ & + & (an(ix,jy,kz,lns)*(917.)**2* gsnow1*(1.0+snu)**(4./3.)) + ELSE ! otherwise small enough to assume ice spheres? + gtmp(ix,kz) = (36./pi**2) * 1.e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + ENDIF + ENDIF ENDIF @@ -7889,6 +8168,7 @@ SUBROUTINE NUCOND & & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & + & ,thproc,numproc, dx1,dy1,gz & & ,axtra,io_flag & & ,ssfilt,t00,t77,flag_qndrop & & ) @@ -7943,6 +8223,9 @@ SUBROUTINE NUCOND & ! local + integer, intent(in) :: numproc + real, intent(inout) :: thproc(nz,numproc) + real, intent(in) :: dx1,dy1, gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) logical :: io_flag @@ -8561,13 +8844,22 @@ SUBROUTINE NUCOND & IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) - qx(mgs,lc)*rho0(mgs)*dv/dtp ! evaporation rate + ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp ENDIF qx(mgs,lc) = 0. IF ( restoreccn ) THEN IF ( irenuc <= 2 ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ENDIF ENDIF IF ( lccna > 1 ) THEN ccna(mgs) = ccna(mgs) - cx(mgs,lc) @@ -8581,7 +8873,13 @@ SUBROUTINE NUCOND & IF ( qx(mgs,lc) .le. 0. ) THEN IF ( restoreccn ) THEN IF ( irenuc <= 2 ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) +! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) +! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ENDIF ENDIF IF ( lccna > 1 ) THEN ccna(mgs) = ccna(mgs) - cx(mgs,lc) @@ -8592,7 +8890,13 @@ SUBROUTINE NUCOND & tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size IF ( restoreccn ) THEN IF ( irenuc <= 2 ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) +! ccnc(mgs) = ccnc(mgs) + tmp + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + tmp + ENDIF ENDIF IF ( lccna > 1 ) THEN ccna(mgs) = ccna(mgs) - tmp @@ -8601,6 +8905,11 @@ SUBROUTINE NUCOND & cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) - felv(mgs)*QEVAP/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) - QEVAP*rho0(mgs)*dv/dtp ! evaporation rate + ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp ENDIF @@ -8871,6 +9180,11 @@ SUBROUTINE NUCOND & IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) ENDIF + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + e1*(DCLOUD + dqr)*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + (DCLOUD + dqr)*rho0(mgs)*dv/dtp ! condensation rate + ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp @@ -8938,6 +9252,11 @@ SUBROUTINE NUCOND & thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate + ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp ENDIF @@ -9195,6 +9514,11 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate + ENDIF ENDIF ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air @@ -9301,6 +9625,11 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate + ENDIF ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) ENDIF @@ -9359,6 +9688,11 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate + ENDIF ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ENDIF @@ -9406,6 +9740,11 @@ SUBROUTINE NUCOND & IF ( qvex .gt. 0.0 ) THEN thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + IF ( numproc > 1 ) THEN + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*qvex/(CP*pi0(mgs))*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + qvex*rho0(mgs)*dv/dtp ! condensation rate + ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp ENDIF @@ -9582,6 +9921,8 @@ SUBROUTINE NUCOND & ! ! Redistribution everywhere in the domain... ! + IF ( .true. ) THEN + frac = 1.0 ! 0.25 ! 1.0 ! 0.2 ! ! alternate test version for ipconc .ge. 3 @@ -9629,6 +9970,10 @@ SUBROUTINE NUCOND & IF ( lhlw .gt. 1 ) THEN an(ix,jy,kz,lhlw) = 0.0 ENDIF + + IF ( lnhlf .gt. 1 ) THEN + an(ix,jy,kz,lnhlf) = 0.0 + ENDIF IF ( lzhl .gt. 1 ) THEN an(ix,jy,kz,lzhl) = 0.0 @@ -9702,9 +10047,9 @@ SUBROUTINE NUCOND & end if + ENDIF !lhl - ENDIF !lhl if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then @@ -9725,6 +10070,10 @@ SUBROUTINE NUCOND & IF ( lhw .gt. 1 ) THEN an(ix,jy,kz,lhw) = 0.0 ENDIF + + IF ( lnhf .gt. 1 ) THEN + an(ix,jy,kz,lnhf) = 0.0 + ENDIF IF ( lzh .gt. 1 ) THEN an(ix,jy,kz,lzh) = 0.0 @@ -9942,7 +10291,7 @@ SUBROUTINE NUCOND & ! write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst) ! write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) ! ENDIF - IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) ) THEN + IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN ! an(ix,jy,kz,lccn) = & ! an(ix,jy,kz,lccn) + Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst)) ! Equivalent form after expanding last term: @@ -9960,6 +10309,7 @@ SUBROUTINE NUCOND & ! end do end do + ENDIF ! true/false IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' ! @@ -9996,8 +10346,10 @@ subroutine nssl_2mom_gs & ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,tmp3d,tkediss & + & ,thproc,numproc,dx1,dy1 & & ,timevtcalc,axtra,io_flag & - & ,rainprod2d, evapprod2d & + & , has_wetscav,rainprod2d, evapprod2d & + & ,errmsg,errflg & & ,elec,its,ids,ide,jds,jde & & ) @@ -10077,6 +10429,10 @@ subroutine nssl_2mom_gs & integer nxend,nyend,nzend,nzbeg integer :: my_rank = 0 integer, parameter :: myprock = 1, nprock = 1 + logical, intent(in) :: has_wetscav + integer, intent(in) :: numproc + real, intent(inout) :: thproc(nz,numproc) + real, intent(in) :: dx1,dy1 real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) @@ -10092,6 +10448,7 @@ subroutine nssl_2mom_gs & integer iraincv, icgxconv parameter ( iraincv = 1, icgxconv = 1) real ffrz + real :: ffrzh = 1.0 real qcitmp,cirdiatmp ! ,qiptmp,qirtmp real ccwtmp,ccitmp ! ,ciptmp,cirtmp @@ -10101,7 +10458,7 @@ subroutine nssl_2mom_gs & double precision dp1 - double precision frac, frach, xvfrz + double precision frac, frach, xvfrz, xvbiggsnow double precision :: timevtcalc double precision :: dpt1,dpt2 @@ -10115,7 +10472,9 @@ subroutine nssl_2mom_gs & logical, parameter :: usegamxinf3 = .false. ! real rar ! rime accretion rate as calculated from qxacw - + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg ! a few vars for time-split fallout real vtmax integer n,ndfall @@ -10336,7 +10695,7 @@ subroutine nssl_2mom_gs & real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia,rmas real :: snowmeltmass = 0 - real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain +! real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain real, parameter :: rimedens = 500. ! default rime density ! real svc(ngs) ! droplet volume @@ -10380,7 +10739,7 @@ subroutine nssl_2mom_gs & real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn parameter ( rwradmn = 50.e-6 ) real dh0 - real dg0(ngs) + real dg0(ngs),df0(ngs) real clionpmx,clionnmx parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 @@ -10415,21 +10774,25 @@ subroutine nssl_2mom_gs & real :: gfm1(ngs),gfm2(ngs) real :: hfm1(ngs),hfm2(ngs) - logical :: wetsfc(ngs),wetsfchl(ngs) - logical :: wetgrowth(ngs), wetgrowthhl(ngs) + logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs) + logical :: wetgrowth(ngs), wetgrowthhl(ngs), wetgrowthf(ngs) real qitmp(ngs),qistmp(ngs) - real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs) - real rzxs(ngs) - real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs),cdh(ngs),cdhl(ngs) + real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs), rzxhlf(ngs) + real rzxs(ngs), rzxf(ngs) +! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + real cdh(ngs),cdhl(ngs) + real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) real vt2ave(ngs) real :: qcwresv(ngs), ccwresv(ngs) ! "reserved" droplet mass and number that are too small for accretion + real :: lfsave(ngs,6) real :: qx(ngs,lv:lhab) real :: qxw(ngs,ls:lhab) real :: qxwlg(ngs,lh:lhab) + real :: chxf(ngs,lh:lhab) real :: cx(ngs,lc:lhab) real :: cxmxd(ngs,lc:lhab) real :: qxmxd(ngs,lv:lhab) @@ -10446,8 +10809,8 @@ subroutine nssl_2mom_gs & real :: rimdn(ngs,li:lhab) real :: raindn(ngs,li:lhab) real :: alpha(ngs,lc:lhab) - real :: dab0lh(ngs,lc:lhab,lr:lhab) - real :: dab1lh(ngs,lc:lhab,lr:lhab) + real :: dab0lh(ngs,lc:lhab,lc:lhab) + real :: dab1lh(ngs,lc:lhab,lc:lhab) real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis real :: qsimxsub(ngs) ! max depositionof qi+qs+qis @@ -10550,7 +10913,7 @@ subroutine nssl_2mom_gs & real csaci(ngs), csacs(ngs) real cracw(ngs) real chacw(ngs), chacr(ngs) - real :: chlacw(ngs) ! = 0.0 + real :: chlacw(ngs) real chaci(ngs), chacs(ngs) ! real :: chlacr(ngs) @@ -10577,6 +10940,7 @@ subroutine nssl_2mom_gs & real crcev(ngs) real crshr(ngs) + real cwshw(ngs), qwshw(ngs) ! ! ! arrays for w-ac-x ; x-ac-w @@ -10592,9 +10956,10 @@ subroutine nssl_2mom_gs & real qsacw(ngs) ! ,qwacs(ngs), real qhacw(ngs) ! qwach(ngs), - real :: qhlacw(ngs) ! = 0.0 + real :: qhlacw(ngs) ! real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + real qfmul1(ngs),cfmul1(ngs) ! real qsacws(ngs) @@ -10610,7 +10975,7 @@ subroutine nssl_2mom_gs & real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) - real :: qhlacr(ngs),qhlacrmlr(ngs) ! = 0.0 + real :: qhlacr(ngs),qhlacrmlr(ngs) real qsacrs(ngs) !,qracss(ngs) ! ! ice - ice interactions @@ -10620,30 +10985,30 @@ subroutine nssl_2mom_gs & real qhaci(ngs) real qhacs(ngs) - real :: qhacis(ngs) = 0.0 - real :: chacis(ngs) = 0.0 - real :: chacis0(ngs) = 0.0 + real :: qhacis(ngs) + real :: chacis(ngs) + real :: chacis0(ngs) real :: csaci0(ngs) ! collision rate only real :: chaci0(ngs) ! collision rate only real :: chacs0(ngs) ! collision rate only - real :: chlaci0(ngs) ! = 0.0 - real :: chlacis(ngs) = 0.0 - real :: chlacis0(ngs) = 0.0 - real :: chlacs0(ngs) ! = 0.0 + real :: chlaci0(ngs) + real :: chlacis(ngs) + real :: chlacis0(ngs) + real :: chlacs0(ngs) real :: qsaci0(ngs) ! collision rate only real :: qsacis0(ngs) ! collision rate only real :: qhaci0(ngs) ! collision rate only real :: qhacis0(ngs) ! collision rate only real :: qhacs0(ngs) ! collision rate only - real :: qhlaci0(ngs) ! = 0.0 - real :: qhlacis0(ngs) ! = 0.0 - real :: qhlacs0(ngs) ! = 0.0 + real :: qhlaci0(ngs) + real :: qhlacis0(ngs) + real :: qhlacs0(ngs) - real :: qhlaci(ngs) ! = 0.0 - real :: qhlacis(ngs) ! = 0.0 - real :: qhlacs(ngs) ! = 0.0 + real :: qhlaci(ngs) + real :: qhlacis(ngs) + real :: qhlacs(ngs) ! ! conversions ! @@ -10652,11 +11017,13 @@ subroutine nssl_2mom_gs & real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) real zhacw(ngs), zhacs(ngs), zhaci(ngs) real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs) + real zfacw(ngs), zfacs(ngs), zfaci(ngs) + real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs) real zhmlrtmp,zhmlr0inf,zhlmlr0inf - real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs) + real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs) real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) real zhcns(ngs), zhcni(ngs) - real zhwdn(ngs) ! change in Z due to density changes + real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes real zhldn(ngs) ! change in Z due to density changes real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs) @@ -10692,10 +11059,6 @@ subroutine nssl_2mom_gs & real qismlr(ngs) ! - real qfdpv(ngs),qfsbv(ngs) ! qfcnv(ngs),qfevv(ngs), - real qfmlr(ngs),qfdsv(ngs) ! ,qfcev(ngs) - real qfwet(ngs),qfdry(ngs),qfshr(ngs) - real qfshrp(ngs) ! real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) @@ -10719,7 +11082,7 @@ subroutine nssl_2mom_gs & real qhlcevlg(ngs), chlcevlg(ngs) real qhcevlg(ngs), chcevlg(ngs) - real vhfzh(ngs) ! change in volume from water that freezes on mixed-phase graupel + real vhfzh(ngs), vffzf(ngs) ! change in volume from water that freezes on mixed-phase graupel, frozen drops real vhlfzhl(ngs) ! change in volume from water that freezes on mixed-phase hail real vhshdr(ngs) !accreted water that leaves on graupel (mixedphase) @@ -10728,6 +11091,7 @@ subroutine nssl_2mom_gs & real vhlmlr(ngs) !melt water that leaves hail (single phase) real vhsoak(ngs) ! aquired water that seeps into graupel. real vhlsoak(ngs) ! aquired water that seeps into hail. + ! real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs), real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs) @@ -10759,10 +11123,10 @@ subroutine nssl_2mom_gs & real qrztot(ngs),qrzmax(ngs),qrzfac(ngs) real qrcev(ngs) real qrshr(ngs) - real fsw(ngs),fhw(ngs),fhlw(ngs) !liquid water fractions + real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions real qhcnf(ngs) - real :: qhlcnh(ngs) ! = 0.0 + real :: qhlcnh(ngs) real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel @@ -10772,17 +11136,19 @@ subroutine nssl_2mom_gs & real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) real ehxr(ngs),ehlr(ngs),egmr(ngs) - real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs) + real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) real ehscnv(ngs) real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) + real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs) real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs) real esiclsn(ngs) real :: ehs_collsn = 0.5, ehi_collsn = 1.0 + real :: efs_collsn = 0.5, efi_collsn = 1.0 real :: ehls_collsn = 1.0, ehli_collsn = 1.0 real :: esi_collsn = 1.0 @@ -10790,7 +11156,7 @@ subroutine nssl_2mom_gs & real cwr(8,2) ! radius and inverse of interval data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & ! radius & 1.0, 1.0, 0.5, 0.5, 0.5, 0.2, 0.2, 1. / ! inverse of interval - integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs) + integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs), ifwr(ngs) real grad(6,2) ! graupel radius and inverse of interval data grad / 100., 200., 300., 400., 600., 1000., & & 1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1. / @@ -10805,9 +11171,12 @@ subroutine nssl_2mom_gs & ! : 0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400 - real da0lr(ngs) + real da0lr(ngs),da1lr(ngs) + real da0lc(ngs),da1lc(ngs) real da0lh(ngs) real da0lhl(ngs) + real da0lf(ngs) + real :: da0lx(ngs,lr:lhab) real va0 (lc:lqmx) ! collection coefficients from Seifert 2005 real vab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 @@ -10836,6 +11205,7 @@ subroutine nssl_2mom_gs & real pvhwi(ngs), pvhwd(ngs) + real pvfwi(ngs), pvfwd(ngs) real pvhli(ngs), pvhld(ngs) real pvswi(ngs), pvswd(ngs) ! @@ -10866,6 +11236,7 @@ subroutine nssl_2mom_gs & real pzrwi(ngs), pzrwd(ngs) real pzhwi(ngs), pzhwd(ngs) + real pzfwi(ngs), pzfwd(ngs) real pzhli(ngs), pzhld(ngs) real pzswi(ngs), pzswd(ngs) @@ -10939,14 +11310,16 @@ subroutine nssl_2mom_gs & ! ! Miscellaneous variables ! + real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. + real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh integer lqrw real vt real arg ! gamma is a function real erbnd1, fdgt1, costhe1 real qeps - real dyi2,dzi2,cp608,bta1,cnit,dragh,dnz00,pii - real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds,gr + real dyi2,dzi2,bta1,cnit,dragh,dnz00,pii ! ,cp608 + real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds real gf1palp(ngs) ! for storing Gamma[1.0 + alphar] @@ -11077,6 +11450,7 @@ subroutine nssl_2mom_gs & ENDDO + ffrzh = 1 ! DO il = lc,lhab ! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) ! ENDDO @@ -11108,7 +11482,7 @@ subroutine nssl_2mom_gs & ! constants ! - cp608 = 0.608 +! cp608 = 0.608 aradcw = -0.27544 bradcw = 0.26249e+06 cradcw = -1.8896e+10 @@ -11139,7 +11513,7 @@ subroutine nssl_2mom_gs & gf4p5 = 11.63172839656745 ! gamma(4.0+0.5) gf3ds = 3.0458730354120997 ! gamma(3.0+ds) gf1ds = 0.8863557896089221 ! gamma(1.0+ds) - gr = 9.8 + gf43rds = 0.8929795116 ! gamma(4./3.) gf53rds = 0.9027452930 ! gamma(5./3.) gf73rds = 1.190639349 ! gamma(7./3.) @@ -11250,6 +11624,12 @@ subroutine nssl_2mom_gs & rwmasn = xvmn(lr)*1000. rwmasx = xvmx(lr)*1000. + IF ( biggsnowdiam > 0.0 ) THEN + xvbiggsnow = (pi/6.0)*biggsnowdiam**3 + ELSE + xvbiggsnow = xvmn(lh) + ENDIF + ! ! ci constants in mks units ! @@ -11354,6 +11734,8 @@ subroutine nssl_2mom_gs & IF ( lhl > 1 ) THEN IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) ishail = .true. ENDIF + + if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & @@ -11373,8 +11755,8 @@ subroutine nssl_2mom_gs & if ( ngscnt .eq. 0 ) go to 9998 - if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5' - + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5, ngscnt = ',ngscnt + ! write(0,*) 'allocating qc' @@ -11384,6 +11766,7 @@ subroutine nssl_2mom_gs & xdia(:,:,:) = 0.0 raindn(:,:) = 900. cx(:,:) = 0.0 + IF ( lnhf > 1 .or. lnhlf > 1 ) chxf(:,:) = 0.0 alpha(:,:) = 0.0 DO il = li,lhab DO mgs = 1,ngscnt @@ -11393,6 +11776,7 @@ subroutine nssl_2mom_gs & ! ! define temporaries for state variables to be used in calculations ! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = def temps' do mgs = 1,ngscnt kgsm(mgs) = max(kgs(mgs)-1,1) kgsp(mgs) = min(kgs(mgs)+1,nz-1) @@ -11479,20 +11863,30 @@ subroutine nssl_2mom_gs & alpha(:,ls) = xnu(ls) ENDIF - DO il = lc,lhab + DO il = lr,lhab do mgs = 1,ngscnt IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) - DO ic = lr,lhab - dab0lh(mgs,il,ic) = dab0(ic,il) - dab1lh(mgs,il,ic) = dab1(ic,il) + + + DO ic = lc,lhab + dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) ENDDO ENDDO end do ! DO mgs = 1,ngscnt + DO il = lr,lhab + da0lx(:,il) = da0(il) + ENDDO da0lh(:) = da0(lh) da0lr(:) = da0(lr) + da1lr(:) = da1(lr) + da0lc(:) = da0(lc) + da1lc(:) = da1(lc) + + IF ( lzh < 1 .or. lzhl < 1 ) THEN rzxhlh(:) = rzhl/rz ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN @@ -11529,6 +11923,7 @@ subroutine nssl_2mom_gs & ! ssmax = 0.0 + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b' if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt @@ -11626,7 +12021,11 @@ subroutine nssl_2mom_gs & ENDIF ENDIF ENDIF + + end do + + end if if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then @@ -11649,6 +12048,8 @@ subroutine nssl_2mom_gs & ENDIF ENDIF ENDIF + + end do end if @@ -11832,6 +12233,7 @@ subroutine nssl_2mom_gs & ENDIF ENDIF + IF ( lhl .gt. 1 ) THEN xdn(mgs,lhl) = xdn0(lhl) @@ -11924,7 +12326,8 @@ subroutine nssl_2mom_gs & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & & ipconc,ndebug,ngs,nz,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) + & itype1,itype2,temcg,infdo,alpha,0,axx,bxx) ! ,cdh,cdhl) +! & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) IF ( lwsm6 .and. ipconc == 0 ) THEN @@ -11986,7 +12389,7 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 2 ) THEN DO mgs = 1,ngscnt - rb(mgs) = 0.5*xdia(mgs,lc,1)*((1./(1.+alpha(mgs,lc))))**(1./6.) + rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.) xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) IF ( rb(mgs) .gt. 3.51e-6 ) THEN @@ -12111,7 +12514,7 @@ subroutine nssl_2mom_gs & DO mgs = 1,ngscnt - DO il = lh,lhab ! graupel and hail only + DO il = lh,lhab ! graupel and hail only (and frozen drops) vshdgs(mgs,il) = vshd ! base value @@ -12152,6 +12555,7 @@ subroutine nssl_2mom_gs & erw(mgs) = 0.0 esw(mgs) = 0.0 ehw(mgs) = 0.0 + efw(mgs) = 0.0 ehlw(mgs) = 0.0 ! ehxw(mgs) = 0.0 ! @@ -12237,6 +12641,7 @@ subroutine nssl_2mom_gs & ENDDO ENDIF + IF ( lhl .gt. 1 ) THEN ! hail is turned on ihlr(mgs) = 1 IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN @@ -12530,6 +12935,7 @@ subroutine nssl_2mom_gs & ENDIF ! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density +! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density ehs(mgs) = Min(ehs(mgs),ehsmax) IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0 end if @@ -12551,7 +12957,7 @@ subroutine nssl_2mom_gs & end if ENDIF - + ! ! ! Hail: Collection (cxc) efficiencies @@ -12682,6 +13088,8 @@ subroutine nssl_2mom_gs & ! end if ! end do + + ! ! ! @@ -12873,7 +13281,7 @@ subroutine nssl_2mom_gs & qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt* & & ( da0(ls)*xdia(mgs,ls,3)**2 + & & dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) ) csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc) ENDIF @@ -12959,6 +13367,7 @@ subroutine nssl_2mom_gs & ! ! ! + if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' ! do mgs = 1,ngscnt @@ -12990,8 +13399,8 @@ subroutine nssl_2mom_gs & qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,lc,lh)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) + & dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) ENDIF qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) @@ -13042,10 +13451,10 @@ subroutine nssl_2mom_gs & rimdn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) ! IF ( igs(mgs) == 30 ) THEN -! write(0,*) 'k,vt: ',kgs(mgs),vt, vtxbar(mgs,lh,1),vtxbar(mgs,lh,2), rhovt(mgs)*axh(mgs)*( (alpha(mgs,lh)+3.)*xdia(mgs,lh,1) )**bxh(mgs) +! write(0,*) 'k,vt: ',kgs(mgs),vt, vtxbar(mgs,lh,1),vtxbar(mgs,lh,2), rhovt(mgs)*axx(mgs,lh)*( (alpha(mgs,lh)+3.)*xdia(mgs,lh,1) )**bxx(mgs,lh) ! write(0,*) 'diam: char, mean, maxmass = ',xdia(mgs,lh,1),xdia(mgs,lh,3),(alpha(mgs,lh)+3.)*xdia(mgs,lh,1) -! write(0,*) 'ax,bx,cd,xdn = ',axh(mgs),bxh(mgs),cdxgs(mgs,lh),xdn(mgs,lh) -! write(0,*) 'vt_char,vt_mean = ',rhovt(mgs)*axh(mgs)*( xdia(mgs,lh,1) )**bxh(mgs),rhovt(mgs)*axh(mgs)*( xdia(mgs,lh,3) )**bxh(mgs) +! write(0,*) 'ax,bx,cd,xdn = ',axx(mgs,lh),bxx(mgs,lh),cdxgs(mgs,lh),xdn(mgs,lh) +! write(0,*) 'vt_char,vt_mean = ',rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,1) )**bxx(mgs,lh),rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,3) )**bxx(mgs,lh) ! write(0,*) 'rimdn,alpha = ',rimdn(mgs,lh),alpha(mgs,lh) ! ENDIF @@ -13096,7 +13505,7 @@ subroutine nssl_2mom_gs & qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da1(li)*xdia(mgs,li,3)**2 ) qhaci(mgs) = Min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) ) ELSE @@ -13124,7 +13533,7 @@ subroutine nssl_2mom_gs & qhacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*qx(mgs,lis)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,lis,lh)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & dab1lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & & da1(li)*xdia(mgs,lis,3)**2 ) qhacis(mgs) = Min( ehis(mgs)*qhacis0(mgs), qxmxd(mgs,lis) ) ENDIF @@ -13144,7 +13553,7 @@ subroutine nssl_2mom_gs & qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & & da1(ls)*xdia(mgs,ls,3)**2 ) qhacs(mgs) = Min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) ) @@ -13182,8 +13591,9 @@ subroutine nssl_2mom_gs & qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,lr,lh)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & - & da1(lr)*xdia(mgs,lr,3)**2 ) + & dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da1lr(mgs)*xdia(mgs,lr,3)**2 ) +! & da1(lr)*xdia(mgs,lr,3)**2 ) ! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp !! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) !! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) @@ -13209,14 +13619,14 @@ subroutine nssl_2mom_gs & ! : 1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) + ! : 2.*xdia(mgs,lh,2)) -! chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* -! : ( da0lh(mgs)*xdia(mgs,lh,3)**2 + -! : dab0lh(mgs,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + -! : da0(lr)*xdia(mgs,lr,3)**2 ) + chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da0lr(mgs)*xdia(mgs,lr,3)**2 ) ! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp - chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) chacr(mgs) = min(chacr(mgs),crmxd(mgs)) IF ( lzh .gt. 1 ) THEN @@ -13300,8 +13710,8 @@ subroutine nssl_2mom_gs & qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,lc,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) + & dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) @@ -13361,7 +13771,7 @@ subroutine nssl_2mom_gs & qhlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,li,lhl)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & & da1(li)*xdia(mgs,li,3)**2 ) ! qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) ) qhlaci(mgs) = Min( ehli(mgs)*qhlaci0(mgs), qimxd(mgs) ) @@ -13382,7 +13792,7 @@ subroutine nssl_2mom_gs & qhlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,ls,lhl)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & & da1(ls)*xdia(mgs,ls,3)**2 ) qhlacs(mgs) = Min( ehls(mgs)*qhlacs0(mgs), qsmxd(mgs) ) @@ -13406,8 +13816,9 @@ subroutine nssl_2mom_gs & qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,lr,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & - & da1(lr)*xdia(mgs,lr,3)**2 ) + & dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da1lr(mgs)*xdia(mgs,lr,3)**2 ) +! & da1(lr)*xdia(mgs,lr,3)**2 ) ! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp !! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) !! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) @@ -13426,8 +13837,8 @@ subroutine nssl_2mom_gs & ELSE chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab0(lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & - & da0(lr)*xdia(mgs,lr,3)**2 ) + & dab0lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da0lr(mgs)*xdia(mgs,lr,3)**2 ) chlacr(mgs) = min(chlacr(mgs),crmxd(mgs)) @@ -13459,7 +13870,7 @@ subroutine nssl_2mom_gs & qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & & dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) ) ENDIF @@ -13534,7 +13945,7 @@ subroutine nssl_2mom_gs & qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & - & dab1lh(mgs,lr,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & dab1lh(mgs,li,lr)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da1(lr)*xdia(mgs,lr,3)**2 ) qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) @@ -13542,7 +13953,7 @@ subroutine nssl_2mom_gs & ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & - & dab0lh(mgs,lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & + & dab0lh(mgs,li,lr)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & & da0(lr)*xdia(mgs,lr,3)**2 ) ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) @@ -13640,7 +14051,7 @@ subroutine nssl_2mom_gs & IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN IF ( ciacr(mgs) > qxmin(lh) ) THEN xvfrz = rho0(mgs)*qiacr(mgs)/(ciacr(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density - frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) qiacrs(mgs) = (1.-frach)*qiacr(mgs) ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) @@ -13783,6 +14194,7 @@ subroutine nssl_2mom_gs & ! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) end do end if + ! ! ! @@ -13841,7 +14253,7 @@ subroutine nssl_2mom_gs & chaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab0lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & dab0lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da0(li)*xdia(mgs,li,3)**2 ) ELSE @@ -13869,7 +14281,7 @@ subroutine nssl_2mom_gs & chacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*cx(mgs,lis)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab0lh(mgs,lis,lh)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & dab0lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & & da0(lis)*xdia(mgs,lis,3)**2 ) @@ -13891,7 +14303,7 @@ subroutine nssl_2mom_gs & chacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab0lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & dab0lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & & da0(ls)*xdia(mgs,ls,3)**2 ) ELSE @@ -14050,11 +14462,12 @@ subroutine nssl_2mom_gs & cautn(mgs) = 0.0 ENDDO + IF ( dmrauto >= -1 ) THEN !{ DO mgs = 1,ngscnt ! qracw(mgs) = 0.0 ! cracw(mgs) = 0.0 IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN - ! .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing + !( .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing volb = xv(mgs,lc)*(1./(1.+alpha(mgs,lc)))**(1./2.) cautn(mgs) = Min(ccmxd(mgs), & & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) @@ -14151,6 +14564,8 @@ subroutine nssl_2mom_gs & ENDIF ENDDO + + ENDIF !} dmrauto >= 0 @@ -14325,19 +14740,21 @@ subroutine nssl_2mom_gs & crfrz(mgs) = 0.0 qrfrz(mgs) = 0.0 + qrfrzf(mgs) = 0.0 ELSE !{ IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN +! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 crfrzs(mgs) = crfrz(mgs) qrfrzs(mgs) = qrfrz(mgs) - ELSEIF ( dbigg < Max(dfrz,dhmn) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals + ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! crfrzs(mgs) = crfrz(mgs) @@ -15042,17 +15459,17 @@ subroutine nssl_2mom_gs & del = tmp - dgam*i g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - tmp = 2.5 + alpha(mgs,lh) + 0.5*bxh(mgs) + tmp = 2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh) i = Int(dgami*(tmp)) del = tmp - dgam*i y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp - hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxh(mgs)))*Sqrt(axh(mgs)*rhovt(mgs)) + hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))*Sqrt(axx(mgs,lh)*rhovt(mgs)) hwvent(mgs) = & & ( 0.78*x + y*hwventy(mgs) ) ! & -! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxh(mgs)))* & -! & Sqrt(axh(mgs)*rhovt(mgs)) ) +! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))* & +! & Sqrt(axx(mgs,lh)*rhovt(mgs)) ) ENDIF ELSE @@ -15061,6 +15478,7 @@ subroutine nssl_2mom_gs & ENDIF end do + hlvent(:) = 0.0 hlventy(:) = 0.0 @@ -15096,16 +15514,16 @@ subroutine nssl_2mom_gs & del = tmp - dgam*i g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxhl(mgs) + tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl) i = Int(dgami*(tmp)) del = tmp - dgam*i y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions - hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxhl(mgs)))*Sqrt(axhl(mgs)*rhovt(mgs)) + hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))*Sqrt(axx(mgs,lhl)*rhovt(mgs)) hlvent(mgs) = 0.78*x + y*hlventy(mgs) ! & -! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxhl(mgs)))* & -! & Sqrt(axhl(mgs)*rhovt(mgs))) +! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))* & +! & Sqrt(axx(mgs,lhl)*rhovt(mgs))) ! : Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp ENDIF @@ -15168,6 +15586,7 @@ subroutine nssl_2mom_gs & qhfzhlg(:) = 0.0 qhlfzhllg(:) = 0.0 vhfzh(:) = 0.0 + vffzf(:) = 0.0 vhlfzhl(:) = 0.0 qsfzs(:) = 0.0 zsmlr(:) = 0.0 @@ -15192,6 +15611,7 @@ subroutine nssl_2mom_gs & ! qhlsave(:) = 0.0 chlmlrr(:) = 0.0 + if ( .not. mixedphase ) then !{ do mgs = 1,ngscnt ! @@ -15203,6 +15623,7 @@ subroutine nssl_2mom_gs & & (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & ! /rhosm & & , 0.0 ) ENDIF + ! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs), ! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv) @@ -15225,8 +15646,9 @@ subroutine nssl_2mom_gs & & , 0.0 ) ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results - write(0,*) 'ibinhmlr = 1 not available for 2-moment' - STOP + errmsg = 'ibinhmlr = 1 not available for 2-moment' + errflg = 1 + RETURN ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN @@ -15349,7 +15771,7 @@ subroutine nssl_2mom_gs & ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lh,1) ) x = gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp - y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxh(mgs), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh), ratio)/g1palp hwvent1 = 0.78*x + y*hwventy(mgs) @@ -15430,7 +15852,7 @@ subroutine nssl_2mom_gs & ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lhl,1) ) x = gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp - y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxhl(mgs), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl), ratio)/g1palp hwvent1 = 0.78*x + y*hlventy(mgs) @@ -15780,9 +16202,9 @@ subroutine nssl_2mom_gs & qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) - qhdpv(mgs) = Max(qhdsv(mgs), 0.0) + qhlsbv(mgs) = 0.0 qhldpv(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN @@ -15936,6 +16358,7 @@ subroutine nssl_2mom_gs & & + qhacr(mgs) & & + qhacw(mgs) ! + qhldry(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & @@ -15965,6 +16388,7 @@ subroutine nssl_2mom_gs & qhwet(mgs) = max( 0.0, qhwet(mgs)) ! ENDIF + qhlwet(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN qhlwet(mgs) = & @@ -16003,7 +16427,6 @@ subroutine nssl_2mom_gs & wetsfchl(:) = .false. wetgrowthhl(:) = .false. - do mgs = 1,ngscnt ! ! @@ -16042,7 +16465,6 @@ subroutine nssl_2mom_gs & qsshr(mgs) = -qsdry(mgs) qhshr(mgs) = -qhdry(mgs) qhlshr(mgs) = -qhldry(mgs) - ELSE ! new and correct qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) @@ -16061,7 +16483,6 @@ subroutine nssl_2mom_gs & wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) ! ENDIF - if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) @@ -16072,9 +16493,6 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) - ! why is there a number loss for graupel for shedding? NEED TO CHECK THIS - ! chshr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) - ! IF ( temg(mgs) < tfr ) chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding @@ -16084,23 +16502,6 @@ subroutine nssl_2mom_gs & ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain - IF ( .false. ) THEN - IF ( temg(mgs) < tfr ) THEN - chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding - ELSE - IF(imltshddmr > 0) THEN - ! DTD: If Dmg < sheddiam, then assume complete melting into - ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop - tmp = -Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain - tmp2 = -rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter - chshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) - chshrr(mgs) = -Max(tmp,Min(tmp2,chshrr(mgs))) - ELSE - chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to maximum size allowed for rain or 4.5mm diameter, whichever is smaller -! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain - ENDIF - ENDIF - ENDIF chlshr(mgs) = 0.0 @@ -16117,27 +16518,8 @@ subroutine nssl_2mom_gs & ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain - - IF ( .false. ) THEN - IF ( temg(mgs) < tfr ) THEN - chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding -! chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vr1mm) ) ! maximum of 1mm drops from shedding - ELSE - IF(imltshddmr > 0) THEN - ! DTD: If Dmg < sheddiam, then assume complete melting into - ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop - tmp = -Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain - tmp2 = -rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter - chlshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lhl,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(sheddiam0-sheddiam) - chlshrr(mgs) = -Max(tmp,Min(tmp2,chlshrr(mgs))) - ELSE - chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to 4.5mm diameter or maximum size allowed for rain, whichever is smaller -! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain - ENDIF - ENDIF - ENDIF - ENDIF ! ( lhl > 1 ) + end do end if @@ -16304,7 +16686,6 @@ subroutine nssl_2mom_gs & ! qhlwet(mgs) = 0.0 end if - end do ! ! Ice -> graupel conversion @@ -16391,7 +16772,7 @@ subroutine nssl_2mom_gs & chcnhl(:) = 0.0 vhcnhl(:) = 0.0 zhcnhl(:) = 0.0 - + IF ( lhl .gt. 1 ) THEN @@ -16483,70 +16864,6 @@ subroutine nssl_2mom_gs & ELSEIF ( ihlcnh == 3 ) THEN !{ - IF ( wtest .and. & - ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN - ! convert number, mass, and reflectivity for d > dw - IF ( ipconc == 5 ) THEN - dg0(mgs) = Min( dg0(mgs), hldia1 ) - !dg0(mgs) = hldia1 - ENDIF - - ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) - - - ! mass - tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) - IF ( ipconc == 5 ) THEN - ! tmp2 = Min( 0.25, tmp2 ) - ENDIF - qxd1 = qx(mgs,lh)*(tmp2) - qhlcnh(mgs) = dtpinv*qxd1 - - - - IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN - - ! number - tmp = gaminterp(ratio,alpha(mgs,lh),1,1) - IF ( ipconc == 5 ) THEN - ! tmp = Min( 0.2, tmp ) - ENDIF - cxd1 = cx(mgs,lh)*( tmp) - chlcnh(mgs) = dtpinv*cxd1 - chlcnhhl(mgs) = chlcnh(mgs) - - IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN - dh0 = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs) - IF ( dh0 < xmas(mgs,lhl) ) THEN - ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average - dh0 = (( qxd1*dh0**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average - chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 ) - ELSE -! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size - ENDIF - ENDIF - - - - ELSE - qhlcnh(mgs) = 0.0 - ENDIF - -! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN -! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! ENDIF - -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 -! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 -! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 -! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 - - vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) - vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) - - ENDIF ENDIF !} @@ -16554,47 +16871,6 @@ subroutine nssl_2mom_gs & ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion -! -! Staka and Mansell (2005) type conversion -- assuming alphah = 0 for now! -! -! hldia1 is set in micro_module and namelist - IF ( .true. ) THEN - - ! convert number, mass, and reflectivity for d > hldia1, - ! regardless of wet growth status, but as long as riming > 0 - DO mgs = 1,ngscnt - IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN - ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) - - ! number - tmp = gaminterp(ratio,alpha(mgs,lh),1,1) - cxd1 = cx(mgs,lh)*( tmp) - chlcnh(mgs) = dtpinv*cxd1 - chlcnhhl(mgs) = chlcnh(mgs) - - ! mass - tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) - qxd1 = qx(mgs,lh)*(tmp2) - qhlcnh(mgs) = dtpinv*qxd1 - -! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN -! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! ENDIF - -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 -! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 -! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 -! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 - - vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) - vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) - - ENDIF - - ENDDO - ELSEIF ( ihlcnh == 0 ) THEN do mgs = 1,ngscnt @@ -16619,7 +16895,7 @@ subroutine nssl_2mom_gs & end if end do - ENDIF ! true +! ENDIF ! true ENDIF ! ihlcnh options @@ -16637,9 +16913,10 @@ subroutine nssl_2mom_gs & ENDIF - ENDIF ! lhl > 1 + + ! ! Ziegler snow conversion to graupel @@ -16886,7 +17163,6 @@ subroutine nssl_2mom_gs & chcev(:) = 0.0 qhlcev(:) = 0.0 chlcev(:) = 0.0 - IF ( lhwlg > 1 ) THEN qhcevlg(:) = 0.0 chcevlg(:) = 0.0 @@ -16910,7 +17186,6 @@ subroutine nssl_2mom_gs & qhmul1(:) = 0.0 qhlmul1(:) = 0.0 qsmul1(:) = 0.0 - do mgs = 1,ngscnt ltest = qx(mgs,lh) .gt. qxmin(lh) @@ -17077,7 +17352,6 @@ subroutine nssl_2mom_gs & ! qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) - IF ( lhl .gt. 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN tmp = fimt1(mgs)*(fimta(mgs) + & @@ -17304,11 +17578,13 @@ subroutine nssl_2mom_gs & ! rimc2 = 0.44 ! ! -! zero som arrays +! zero some arrays ! ! do mgs = 1,ngscnt qrshr(mgs) = 0.0 + qwshw(mgs) = 0.0 + cwshw(mgs) = 0.0 qsshrp(mgs) = 0.0 qhshrp(mgs) = 0.0 end do @@ -17320,6 +17596,8 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) + + IF ( ipconc .ge. 3 ) THEN ! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) ) ENDIF @@ -17431,7 +17709,7 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 2 ) THEN do mgs = 1,ngscnt - pccwi(mgs) = (0.0) ! + (1-il5(mgs))*(-cirmlw(mgs)) + pccwi(mgs) = (0.0) - cwshw(mgs) ! + (1-il5(mgs))*(-cirmlw(mgs)) IF ( warmonly < 0.5 ) THEN pccwd(mgs) = & @@ -17560,6 +17838,8 @@ subroutine nssl_2mom_gs & & +crcev(mgs) & & - cracr(mgs) ! > -il5(mgs)*ciracr(mgs) + + ELSEIF ( warmonly < 0.8 ) THEN pcrwi(mgs) = & & crcnw(mgs) & @@ -17665,7 +17945,7 @@ subroutine nssl_2mom_gs & IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp) - pqswd(mgs) = frac*pqswd(mgs) + pcswd(mgs) = frac*pcswd(mgs) chacs(mgs) = frac*chacs(mgs) chlacs(mgs) = frac*chlacs(mgs) @@ -17698,9 +17978,9 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 5 ) THEN ! do mgs = 1,ngscnt pchwi(mgs) = & - & +(ifrzg*crfrzf(mgs) & - & +il5(mgs)*ifiacrg*(ciacrf(mgs) )) & - & + chcnsh(mgs) + chcnih(mgs) + chcnhl(mgs) + & +(ffrzh*ifrzg*crfrzf(mgs) & + & +il5(mgs)*ffrzh*ifiacrg*(ciacrf(mgs) )) & + & + f2h*chcnsh(mgs) + f2h*chcnih(mgs) + chcnhl(mgs) pchwd(mgs) = & & (1-il5(mgs))*chmlr(mgs) & @@ -17708,7 +17988,11 @@ subroutine nssl_2mom_gs & & + chsbv(mgs) & & - il5(mgs)*chlcnh(mgs) & & - cscnh(mgs) + end do + + + ! ! @@ -17716,7 +18000,7 @@ subroutine nssl_2mom_gs & ! IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN ! do mgs = 1,ngscnt - pchli(mgs) = ((1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*(1.0-ifiacrg)*(ciacrf(mgs) )) & + pchli(mgs) = (ffrzh*(1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*ffrzh*(1.0-ifiacrg)*(ciacrf(mgs) )) & & + chlcnhhl(mgs) *rzxhlh(mgs) pchld(mgs) = & @@ -17739,6 +18023,7 @@ subroutine nssl_2mom_gs & ENDIF ENDIF + end do ENDIF @@ -17834,6 +18119,8 @@ subroutine nssl_2mom_gs & pqlwlghld(:) = 0.0 pqlwhli(:) = 0.0 pqlwhld(:) = 0.0 + + ! ! Vapor ! @@ -17890,7 +18177,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt - pqcwi(mgs) = (0.0) + qwcnr(mgs) + pqcwi(mgs) = (0.0) + qwcnr(mgs) - qwshw(mgs) IF ( warmonly < 0.5 ) THEN pqcwd(mgs) = & @@ -18016,9 +18303,11 @@ subroutine nssl_2mom_gs & & -qhmlr(mgs) & !null at this point when wet snow/graupel included & -qsmlr(mgs) - qhlmlr(mgs) & & -qimlr(mgs)) & - & -qsshr(mgs) & !null at this point when wet snow/graupel included - & -qhshr(mgs) & !null at this point when wet snow/graupel included - & -qhlshr(mgs) +! & -qsshr(mgs) & !null at this point when wet snow/graupel included +! & -qhshr(mgs) & !null at this point when wet snow/graupel included +! & -qhlshr(mgs) & + & - qrshr(mgs) + pqrwd(mgs) = & & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & @@ -18027,10 +18316,10 @@ subroutine nssl_2mom_gs & pqrwi(mgs) = & & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & & +(1-il5(mgs))*( & - & -qhmlr(mgs) & !null at this point when wet snow/graupel included - & -qhshr(mgs) & !null at this point when wet snow/graupel included & -qhlmlr(mgs) & !null at this point when wet snow/graupel included - & -qhlshr(mgs) ) !null at this point when wet snow/graupel included + & -qhmlr(mgs) ) & !null at this point when wet snow/graupel included + & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) !null at this point when wet snow/graupel included pqrwd(mgs) = & & il5(mgs)*(-qrfrz(mgs)) & & - qhacr(mgs) & @@ -18179,13 +18468,13 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt pqhwi(mgs) = & - & +il5(mgs)*(ifrzg*qrfrzf(mgs) + (1-il3(mgs))*(ifiacrg)*(qiacrf(mgs)+qracif(mgs))) & - & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & + & +il5(mgs)*(ffrzh*ifrzg*qrfrzf(mgs) + (1-il3(mgs))*ffrzh*ifiacrg*(qiacrf(mgs)+qracif(mgs))) & + & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & ! only used for ipconc < 3 & +il5(mgs)*(qhdpv(mgs)) & & +Max(0.0, qhcev(mgs)) & & +qhacr(mgs)+qhacw(mgs) & & +qhacs(mgs)+qhaci(mgs) & - & + qhcns(mgs) + qhcni(mgs) + qhcnhl(mgs) + & + f2h*qhcns(mgs) + f2h*qhcni(mgs) + qhcnhl(mgs) pqhwd(mgs) = & & qhshr(mgs) & !null at this point when wet graupel included & +(1-il5(mgs))*qhmlr(mgs) & !null at this point when wet graupel included @@ -18193,10 +18482,12 @@ subroutine nssl_2mom_gs & & + qhsbv(mgs) & & + Min(0.0, qhcev(mgs)) & & -qhmul1(mgs) - qhlcnh(mgs) - qscnh(mgs) & - & - qsplinter(mgs) - qsplinter2(mgs) + & - ffrzh*(qsplinter(mgs) + qsplinter2(mgs)) ! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + end do + ! ! Hail ! @@ -18302,7 +18593,7 @@ subroutine nssl_2mom_gs & vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation ! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) ! vhlsoak(:) = 0.0 - + ENDIF ! mixedphase @@ -18351,16 +18642,16 @@ subroutine nssl_2mom_gs & ! : + il5(mgs)*qrfrzf(mgs)/rhofrz ) pvhwi(mgs) = rho0(mgs)*( & - & +il5(mgs)*( ifiacrg*qracif(mgs))/rhofrz & + & +il5(mgs)*( ifiacrg*ffrzh*qracif(mgs))/rhofrz & !erm > + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)? & & + ( il5(mgs)*qhdpv(mgs)/qhdpvdn & & + (qhacs(mgs) + qhaci(mgs))/qhacidn ) ) & & + rho0(mgs)*Max(0.0, qhcev(mgs))/1000. & ! only used in mixed phase: evaporation/condensation of liquid water coating ! > + qhacs(mgs) + qhaci(mgs) )/xdn0(ls) ) & - & + vhcns(mgs) & + & + f2h*vhcns(mgs) & & + vhacr(mgs) + vhacw(mgs) + vhfzh(mgs) & ! qhacw(mgs)/rimdn(mgs,lh) ! > + vhfrh(mgs) & - & + vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs)) + & + f2h*vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs))*ffrzh ! > +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh) ! pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh) @@ -18445,13 +18736,13 @@ subroutine nssl_2mom_gs & DO mgs = 1,ngscnt pvhli(mgs) = rho0(mgs)*( & - & + ( il5(mgs)*(((1.0-ifiacrg)*qracif(mgs))/rhofrz + qhldpv(mgs) ) & + & + ( il5(mgs)*(((1.0-ifiacrg)*ffrzh*qracif(mgs))/rhofrz + qhldpv(mgs) ) & ! & + Max(0.0, qhlcev(mgs)) & ! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) ) & ! xdn0(ls) ) & ! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose & + qhlacs(mgs) + qhlaci(mgs) )/500. ) & ! changed to 500 instead of min graupel density to keep hail density from dropping too much & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & - & + vhlcnhl(mgs) + ((1.0-ifiacrg)*viacrf(mgs) + (1.0-ifrzg)*vrfrzf(mgs)) & + & + vhlcnhl(mgs) + ((1.0-ifiacrg)*ffrzh*viacrf(mgs) + (1.0-ifrzg)*ffrzh*vrfrzf(mgs)) & & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl) pvhld(mgs) = rho0(mgs)*( & @@ -18482,6 +18773,7 @@ subroutine nssl_2mom_gs & & + pqhwi(mgs) + pqhwd(mgs) & & + pqhli(mgs) + pqhld(mgs) ! + ENDDO @@ -18587,6 +18879,7 @@ subroutine nssl_2mom_gs & write(iunit,*) cwacii(mgs),cwfrzc(mgs),cwctfzc(mgs) write(iunit,*) cicichr(mgs) write(iunit,*) chmul1(mgs) + write(iunit,*) cfmul1(mgs) write(iunit,*) chlmul1(mgs) write(iunit,*) csmul(mgs) ! @@ -18923,6 +19216,8 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 ) THEN cx(mgs,lhl) = cx(mgs,lhl) + & & dtp*(pchli(mgs)+pchld(mgs)) + + ENDIF @@ -18931,7 +19226,7 @@ subroutine nssl_2mom_gs & end if - IF ( wrfchem_flag > 0 ) THEN + IF ( has_wetscav ) THEN DO mgs = 1,ngscnt evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + & @@ -19426,6 +19721,104 @@ subroutine nssl_2mom_gs & ! ! Load the save arrays ! + IF ( numproc > 1 ) THEN + DO mgs = 1,ngscnt + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + IF ( ipconc > 2 ) THEN + thproc(kzbeg-1+kgs(mgs),1) = thproc(kzbeg-1+kgs(mgs),1) + crfrzf(mgs)*dtp*dv + ELSE + thproc(kzbeg-1+kgs(mgs),1) = thproc(kzbeg-1+kgs(mgs),1) + qrfrzf(mgs)*rho0(mgs)*dtp*dv + ENDIF + thproc(kzbeg-1+kgs(mgs),2) = thproc(kzbeg-1+kgs(mgs),2) + il5(mgs)*ciacrf(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),3) = thproc(kzbeg-1+kgs(mgs),3) + chcnsh(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),4) = thproc(kzbeg-1+kgs(mgs),4) + chcnih(mgs)*dtp*dv + IF ( qhacw(mgs)+qhacr(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN + thproc(kzbeg-1+kgs(mgs),5) = thproc(kzbeg-1+kgs(mgs),5) + (qhacw(mgs)+qhacr(mgs)+qhshr(mgs))*rho0(mgs)*dtp*dv + ENDIF + thproc(kzbeg-1+kgs(mgs),6) = thproc(kzbeg-1+kgs(mgs),6) + qracw(mgs)*rho0(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),7) = thproc(kzbeg-1+kgs(mgs),7) + qrcnw(mgs)*rho0(mgs)*dtp*dv + IF ( qhacw(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN + thproc(kzbeg-1+kgs(mgs),8) = thproc(kzbeg-1+kgs(mgs),8) + (vhacw(mgs)+vhacr(mgs)+vhshdr(mgs))*dtp*dv +! thproc(kzbeg-1+kgs(mgs),8) = thproc(kzbeg-1+kgs(mgs),8) + qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh)*dtp*dv + ENDIF + thproc(kzbeg-1+kgs(mgs),9) = thproc(kzbeg-1+kgs(mgs),9) + ptem(mgs)*dtp*dv ! latent heating + thproc(kzbeg-1+kgs(mgs),10) = thproc(kzbeg-1+kgs(mgs),10) + & + & ( chmul1(mgs) + chlmul1(mgs) )*dtp*dv + IF ( lf > 1 ) THEN + ELSE + thproc(kzbeg-1+kgs(mgs),11) = thproc(kzbeg-1+kgs(mgs),11) + & + & ( csplinter(mgs) + csplinter2(mgs) )*dtp*dv + ENDIF + thproc(kzbeg-1+kgs(mgs),12) = thproc(kzbeg-1+kgs(mgs),12) + qrfrzf(mgs)*rho0(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),13) = thproc(kzbeg-1+kgs(mgs),13) + il5(mgs)*qiacrf(mgs)*rho0(mgs)*dtp*dv ! mass of rain freezing by ice crystal capture + thproc(kzbeg-1+kgs(mgs),14) = thproc(kzbeg-1+kgs(mgs),14) + crcnw(mgs)*dtp*dv ! rain drop prod. by autoconv. + thproc(kzbeg-1+kgs(mgs),15) = thproc(kzbeg-1+kgs(mgs),15) + (pcrwi(mgs)-crcnw(mgs))*dtp*dv ! rain drop prod by melting/shedding (i.e., everything but autoconv.) +! thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate + thproc(kzbeg-1+kgs(mgs),19) = thproc(kzbeg-1+kgs(mgs),19) + pmlt(mgs)*rho0(mgs)*dv ! melting rate + thproc(kzbeg-1+kgs(mgs),20) = thproc(kzbeg-1+kgs(mgs),20) + pdep(mgs)*rho0(mgs)*dv ! deposition rate + thproc(kzbeg-1+kgs(mgs),21) = thproc(kzbeg-1+kgs(mgs),21) + (psub(mgs)-pdep(mgs))*rho0(mgs)*dv ! sublimation rate + thproc(kzbeg-1+kgs(mgs),22) = thproc(kzbeg-1+kgs(mgs),22) + (pfrz(mgs)-pmlt(mgs))*rho0(mgs)*dv ! freezing rate + +! thproc(kzbeg-1+kgs(mgs),20) = thproc(kzbeg-1+kgs(mgs),20) + (1./pi0(mgs))*felfcp(mgs)*pvap(mgs)*rho0(mgs)*dv ! deposition rate +! thproc(kzbeg-1+kgs(mgs),21) = thproc(kzbeg-1+kgs(mgs),21) + (1./pi0(mgs))*felscp(mgs)*psub(mgs)*rho0(mgs)*dv ! sublimation rate +! thproc(kzbeg-1+kgs(mgs),22) = thproc(kzbeg-1+kgs(mgs),22) + (1./pi0(mgs))*felfcp(mgs)*pfrz(mgs)*rho0(mgs)*dv ! (pfrz(mgs)-pmlt(mgs))*rho0(mgs)*dv ! freezing rate + + thproc(kzbeg-1+kgs(mgs),23) = thproc(kzbeg-1+kgs(mgs),23) + crfrzs(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),24) = thproc(kzbeg-1+kgs(mgs),24) + il5(mgs)*ciacrs(mgs)*dtp*dv + + thproc(kzbeg-1+kgs(mgs),25) = thproc(kzbeg-1+kgs(mgs),25) + qhmlr(mgs)*rho0(mgs)*dv ! melting rate + thproc(kzbeg-1+kgs(mgs),26) = thproc(kzbeg-1+kgs(mgs),26) + qhlmlr(mgs)*rho0(mgs)*dv ! melting rate + + IF ( qhlacw(mgs)+qhlacr(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN + thproc(kzbeg-1+kgs(mgs),27) = thproc(kzbeg-1+kgs(mgs),27) + (qhlacw(mgs)+qhlacr(mgs)+qhlshr(mgs))*rho0(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),28) = thproc(kzbeg-1+kgs(mgs),28) + (qhlacw(mgs))*rho0(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),29) = thproc(kzbeg-1+kgs(mgs),29) + (qhlacr(mgs))*rho0(mgs)*dtp*dv + ENDIF + + IF ( temg(mgs) < tfr ) THEN + thproc(kzbeg-1+kgs(mgs),30) = thproc(kzbeg-1+kgs(mgs),30) + (qhacw(mgs))*rho0(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),31) = thproc(kzbeg-1+kgs(mgs),31) + (qhacr(mgs))*rho0(mgs)*dtp*dv + ENDIF + + thproc(kzbeg-1+kgs(mgs),32) = thproc(kzbeg-1+kgs(mgs),32) + qhlcnh(mgs)*rho0(mgs)*dtp*dv ! graupel mass conversion to hail + + IF ( ihrn > 0 ) THEN + thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + ciihr(mgs)*dtp*dv ! contact freezing of droplets + ELSE + IF ( qwctfz(mgs)*dtp >= qxmin(li) ) THEN + thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + cwctfz(mgs)*dtp*dv ! contact freezing of droplets + ENDIF + ENDIF + thproc(kzbeg-1+kgs(mgs),34) = thproc(kzbeg-1+kgs(mgs),34) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate + IF ( qiint(mgs)*dtp >= qxmin(li) ) THEN + thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + ciint(mgs)*dtp*dv ! primary ice initiation + ENDIF + IF ( lf > 1 ) THEN + ELSE + thproc(kzbeg-1+kgs(mgs),38) = thproc(kzbeg-1+kgs(mgs),38) + (vhacw(mgs)+vhacr(mgs)+vhshdr(mgs))*dtp*dv + ENDIF + IF ( lhl > 1 ) THEN + thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + chlcnhhl(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),37) = thproc(kzbeg-1+kgs(mgs),37) + (vhlacw(mgs)+vhlacr(mgs)+vhlshdr(mgs))*dtp*dv + ELSE + IF ( lf > 1 ) THEN + ELSE + thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + (pchwi(mgs))*dtp*dv + thproc(kzbeg-1+kgs(mgs),39) = thproc(kzbeg-1+kgs(mgs),39) + (pchwd(mgs))*dtp*dv + thproc(kzbeg-1+kgs(mgs),37) = thproc(kzbeg-1+kgs(mgs),37) + (chmlr(mgs))*dtp*dv + ENDIF + ENDIF +! thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate + + +! ptem(mgs) = & +! & (1./pi0(mgs))* & +! & (felfcp(mgs)*pfrz(mgs) & +! & +felscp(mgs)*psub(mgs) & +! & +felvcp(mgs)*pvap(mgs)) + + ENDDO + ENDIF ! Sample code for using the axtra array to load microphysical rates or quantities for output @@ -19461,6 +19854,10 @@ subroutine nssl_2mom_gs & DO il = lc,lhab IF ( ido(il) .eq. 1 ) THEN + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,1) = an(igs(mgs),jy,kgs(mgs),il) + lfsave(mgs,2) = qx(mgs,il) + ENDIF an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) + & & min( an(igs(mgs),jy,kgs(mgs),il), 0.0 ) qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il) @@ -19541,7 +19938,19 @@ subroutine nssl_2mom_gs & ENDIF ! } DO mgs = 1,ngscnt + + IF ( il == lh ) THEN + IF ( lnhf > 1 ) THEN ! number of graupel from frozen drops + an(igs(mgs),jy,kgs(mgs),lnhf) = Max( chxf(mgs,lh), 0.0) + ENDIF + ENDIF + IF ( il == lhl ) THEN + + IF ( lnhlf > 1 ) THEN ! number of hail from frozen drops +! an(igs(mgs),jy,kgs(mgs),lnhlf) = Min( cx(mgs,lhl), Max( chxf(mgs,lhl), 0.0) ) + an(igs(mgs),jy,kgs(mgs),lnhlf) = Max( chxf(mgs,lhl), 0.0) + ENDIF ENDIF an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) ENDDO diff --git a/physics/mp_nsslg.F90 b/physics/mp_nssl.F90 similarity index 58% rename from physics/mp_nsslg.F90 rename to physics/mp_nssl.F90 index a2dc50cce..84531244e 100644 --- a/physics/mp_nsslg.F90 +++ b/physics/mp_nssl.F90 @@ -1,17 +1,17 @@ -!>\file mp_nsslg.F90 +!>\file mp_nssl.F90 !! This file contains NSSL 2-moment MP scheme. -!>\defgroup aansslg NSSL MP Module +!>\defgroup aanssl NSSL MP Module !! This module contains the NSSL microphysics scheme. -module mp_nsslg +module mp_nssl use machine, only : kind_phys, kind_real use module_mp_nssl_2mom, only : nssl_2mom_init, nssl_2mom_driver implicit none - public :: mp_nsslg_init, mp_nsslg_run, mp_nsslg_finalize + public :: mp_nssl_init, mp_nssl_run, mp_nssl_finalize private logical :: is_initialized = .False. @@ -20,90 +20,141 @@ module mp_nsslg contains !> This subroutine is a wrapper around the nssl_2mom_init(). -!! \section arg_table_mp_nsslg_init Argument Table -!! \htmlinclude mp_nsslg_init.html +!! \section arg_table_mp_nssl_init Argument Table +!! \htmlinclude mp_nssl_init.html !! - subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & - mpicomm, mpirank, mpiroot, & - imp_physics, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & - nssl_cccn, nssl_alphah, nssl_alphahl, nssl_hail_on) + subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & + mpicomm, mpirank, mpiroot, & + imp_physics, imp_physics_nssl, & + nssl_cccn, nssl_alphah, nssl_alphahl, & + nssl_ccn_on, nssl_hail_on, nssl_invertccn, first_time_step, & + spechum, qc, qr, qi, qs, qh, qhl, & + cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl, & + csw_phys ) + + use module_mp_nssl_2mom, only: nssl_2mom_init, calcnfromq, na + use physcons, only: con_rd implicit none - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg integer, intent(in) :: ncol integer, intent(in) :: nlev + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + integer, intent(in) :: threads + logical, intent(in) :: restart integer, intent(in) :: mpicomm integer, intent(in) :: mpirank integer, intent(in) :: mpiroot - integer, intent(in) :: threads integer, intent(in) :: imp_physics - integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn + integer, intent(in) :: imp_physics_nssl real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl - logical, intent(in) :: nssl_hail_on + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + logical, intent(in) :: first_time_step + + ! Hydrometeors + real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) + 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) :: qhl(:,:) ! (1:ncol,1:nlev) ! hail + real(kind_phys), intent(inout) :: cccn(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccna(:,:) ! (1:ncol,1:nlev) ! currently not used + 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) :: chl(:,:) ! (1:ncol,1:nlev) ! hail number + real(kind_phys), intent(inout) :: vh(1:ncol,1:nlev) ! graupel volume + real(kind_phys), intent(inout) :: vhl(:,:) ! (1:ncol,1:nlev) ! hail volume + + real(kind_phys), intent(inout) :: csw_phys(1:ncol,1:nlev) + + ! State variables and timestep information + real(kind_phys), intent(inout) :: tgrs(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prsl(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prslk(1:ncol,1:nlev) + ! Air density + real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 + ! Hydrometeors +! real(kind_phys) :: qv_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) +! real(kind_phys) :: qc_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) +! real(kind_phys) :: qr_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) +! real(kind_phys) :: qi_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) +! real(kind_phys) :: qs_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) +! real(kind_phys) :: qh_mp(1:ncol,1:nlev) !< kg kg-1 (graupel dry mixing ratio) + real(kind_phys) :: qhl_mp(1:ncol,1:nlev) !< kg kg-1 (hail dry mixing ratio) +! real(kind_phys) :: nc_mp(1:ncol,1:nlev) !< droplet num. conc. +! real(kind_phys) :: nr_mp(1:ncol,1:nlev) !< rain num. conc. +! real(kind_phys) :: ni_mp(1:ncol,1:nlev) !< ice crystal num. conc. +! real(kind_phys) :: ns_mp(1:ncol,1:nlev) !< snow num. conc. +! real(kind_phys) :: nh_mp(1:ncol,1:nlev) !< graupel num. conc. +! real(kind_phys) :: nhl_mp(1:ncol,1:nlev) !< hail num. conc. + real(kind_phys) :: vh_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + real(kind_phys) :: cccn_mp(1:ncol,1:nlev) + real(kind_phys) :: cccna_mp(1:ncol,1:nlev) + ! create temporaries for hail in case it does not exist + real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) + real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + + real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array ! Local variables: dimensions used in nssl_init - integer :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte + integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k real :: nssl_params(20) integer :: ihailv - + ! Initialize the CCPP error handling variables errflg = 0 errmsg = '' +! write(0,*) 'nssl_init: nlev,ncol,rank = ',nlev,ncol,mpirank - if (is_initialized) return + if (is_initialized .and. .not. first_time_step ) return + IF ( .not. is_initialized ) THEN ! only do this on first call if (mpirank==mpiroot) then write(0,*) ' ----------------------------------------------------------------------------------------------------------------' - write(0,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development, use at your own risk --- WARNING ---' + write(0,*) ' --- CCPP NSSL MP scheme init ---' +! write(0,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development --- WARNING ---' write(0,*) ' ----------------------------------------------------------------------------------------------------------------' write(6,*) ' ----------------------------------------------------------------------------------------------------------------' - write(6,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development, use at your own risk --- WARNING ---' +! write(6,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development --- WARNING ---' + write(6,*) ' --- CCPP NSSL MP scheme init ---' write(6,*) ' ----------------------------------------------------------------------------------------------------------------' end if -! IF ( kind_phys /= kind_real ) THEN -! errflg = 1 -! write(errmsg,'(a)') 'NSSL MP does not yet work for double precision. Compile for single precision' -! return -! ENDIF +! update this when ccn_flag is active? + if ( imp_physics /= imp_physics_nssl ) then + write(errmsg,'(*(a))') "Logic error: namelist choice of microphysics is different from NSSL" + errflg = 1 + return + end if ! Set internal dimensions - ids = 1 ims = 1 - its = 1 - ide = ncol ime = ncol - ite = ncol - jds = 1 + nx = ncol jms = 1 - jts = 1 - jde = 1 jme = 1 - jte = 1 - kds = 1 kms = 1 - kts = 1 - kde = nlev kme = nlev - kte = nlev + nz = nlev nssl_params(:) = 0.0 nssl_params(1) = nssl_cccn nssl_params(2) = nssl_alphah nssl_params(3) = nssl_alphahl - nssl_params(4) = 4.e5 ! nssl_cnoh - nssl_params(5) = 4.e4 ! nssl_cnohl - nssl_params(6) = 4.e5 ! nssl_cnor - nssl_params(7) = 4.e6 ! nssl_cnos + nssl_params(4) = 4.e5 ! nssl_cnoh -- not used for 2-moment + nssl_params(5) = 4.e4 ! nssl_cnohl-- not used for 2-moment + nssl_params(6) = 4.e5 ! nssl_cnor-- not used for 2-moment + nssl_params(7) = 4.e6 ! nssl_cnos-- not used for 2-moment nssl_params(8) = 500. ! nssl_rho_qh nssl_params(9) = 800. ! nssl_rho_qhl nssl_params(10) = 100. ! nssl_rho_qs @@ -112,9 +163,9 @@ subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off nssl_qccn = nssl_cccn/1.225 - if (mpirank==mpiroot) then - write(*,*) 'nssl_init: nssl_qccn = ',nssl_qccn - endif + ! if (mpirank==mpiroot) then + ! write(*,*) 'nssl_init: nssl_qccn = ',nssl_qccn + ! endif IF ( nssl_hail_on ) THEN ihailv = 1 @@ -122,64 +173,159 @@ subroutine mp_nsslg_init(ncol, nlev, errflg, errmsg,threads, & ihailv = -1 ENDIF - IF ( imp_physics == imp_physics_nssl2m ) THEN + IF ( imp_physics == imp_physics_nssl ) THEN ! ( .not. nssl_ccn_flag ) ! write(0,*) 'call nssl_2mom_init' - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & + ihvol=ihailv,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) ! write(0,*) 'done nssl_2mom_init' - ELSEIF ( imp_physics == imp_physics_nssl2mccn ) THEN -! write(0,*) 'call nssl_2mom_init ccn' - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) -! write(0,*) 'done nssl_2mom_init ccn' - ELSE +! ELSE ! write(0,*) 'call nssl_2mom_init ccn: imp_physics, imp_physics_nssl2mccn = ',imp_physics, imp_physics_nssl2mccn - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) +! CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) ! write(0,*) 'done nssl_2mom_init ccn' ENDIF is_initialized = .true. + + ENDIF ! .not. is_initialized + +! IF ( is_initialized .and. ((.not. first_time_step) .or. restart ) ) THEN +! return +! ENDIF + + ! Following code only runs on first time step -- hopefully for all slabs + + !> - Density of air in kg m-3 + rho = prsl/(con_rd*tgrs) + + allocate( an(nx,1,nz,na) ) + an(:,:,:,:) = 0.0 + +! spechum, qc, qr, qi, qs, qh, qhl, & +! cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl ) + + ! use local arrays for variables that might not exist + ! implied loops + IF ( nssl_hail_on ) THEN + qhl_mp = qhl + vhl_mp = vhl + chl_mp = chl + ELSE + qhl_mp = 0 + vhl_mp = 0 + chl_mp = 0 + ENDIF + IF ( nssl_ccn_on ) THEN + cccn_mp = nssl_qccn ! cccn + cccna_mp = 0 + ELSE + cccn_mp = nssl_qccn + cccna_mp = 0 + ENDIF +! qr_mp = qr +! qs_mp = qs +! write(0,*) 'mp_nssl_init1: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh),maxval(rho) +! write(0,*) 'mp_nssl_init: call calcnfromq',restart,is_initialized,first_time_step + call calcnfromq(nx=nx,ny=1,nz=nz,an=an,na=na,nor=0,norz=0,dn=rho, & + & qcw=qc,qci=qi,qsw=qs,qrw=qr,qhw=qh,qhl=qhl_mp, & + & ccw=ccw,cci=cci,csw=csw,crw=crw,chw=chw,chl=chl_mp, & + & cccn=cccn_mp,cccna=cccna_mp, vhw=vh,vhl=vhl_mp ) + +! qr = qr_mp +! qs = qs_mp + + ! write(0,*) 'mp_nssl_init2: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh),maxval(rho) + ! write(0,*) 'mp_nssl_init2: ni,ns,nh maxval: ',maxval(cci),maxval(csw),maxval(chw) +! DO k = 1,nz +! DO i = 1,nx +! IF ( qi(i,k) > 1.e-4 ) write(6,*) 'qi,ni = ',qi(i,k),cci(i,k) +! IF ( qs(i,k) > 1.e-3 ) write(6,*) 'qs,ns = ',qs(i,k),csw(i,k) +! IF ( qh(i,k) > 1.e-3 ) write(6,*) 'qh,nh = ',qh(i,k),chw(i,k) +! ENDDO +! ENDDO + + IF ( nssl_hail_on ) THEN + qhl = qhl_mp + vhl = vhl_mp + chl = chl_mp + ENDIF + IF ( nssl_ccn_on ) THEN + IF ( nssl_invertccn ) THEN + !cccn = cccna_mp + DO k = 1,nlev + DO i = 1,ncol + cccn(i,k) = nssl_qccn - cccn_mp(i,k) + ENDDO + ENDDO + ELSE + cccn = cccn_mp + ENDIF + ENDIF + csw_phys = csw + +! qs = 0 +! qi = 0 +! qr = 0 + +! call calc_eff_radius & +! & (nx=im,ny=1,nz=lm,na=1,jyslab=1 & +! & ,nor=0,norz=0 & +! & ,t1=re_cloud,t2=re_ice,t3=re_snow,t4=re_rain & +! & ,qcw=qc_mp,qci=qi_mp,qsw=qs_mp,qrw=qr_mp & +! & ,ccw=nc_mp,cci=ni_mp,csw=ns_mp,crw=nr_mp & +! & ,dn=rho ) + + + + deallocate( an ) + + return - end subroutine mp_nsslg_init + end subroutine mp_nssl_init -!>\ingroup aansslg -!>\section gen_nsslg NSSL MP General Algorithm +!>\ingroup aanssl +!>\section gen_nssl NSSL MP General Algorithm !>@{ -!> \section arg_table_mp_nsslg_run Argument Table -!! \htmlinclude mp_nsslg_run.html +!> \section arg_table_mp_nssl_run Argument Table +!! \htmlinclude mp_nssl_run.html !! - subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & + subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ! spechum, cccn, qc, qr, qi, qs, qh, qhl, & spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & ccw, crw, cci, csw, chw, chl, vh, vhl, & tgrs, prslk, prsl, phii, omega, dtp, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, & - re_cloud, re_ice, re_snow, & + re_cloud, re_ice, re_snow, re_rain, & imp_physics, & - imp_physics_nssl2m, imp_physics_nssl2mccn, & + imp_physics_nssl, nssl_ccn_on, & nssl_hail_on, nssl_invertccn, ntccn, ntccna, & errflg, errmsg) + + use module_mp_nssl_2mom, only: calcnfromq, na + implicit none integer, intent(in) :: ncol, nlev real(kind_phys), intent(in ) :: con_g real(kind_phys), intent(in ) :: con_rd + integer, intent(in) :: mpirank ! Hydrometeors real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) - real(kind_phys), intent(inout) :: cccn(1:ncol,1:nlev) - real(kind_phys), intent(inout) :: cccna(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccn(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccna(:,:) ! (1:ncol,1:nlev) 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) :: qhl(1:ncol,1:nlev) ! hail + real(kind_phys), intent(inout) :: qhl(:,:) ! (1:ncol,1:nlev) ! hail 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) :: chl(1:ncol,1:nlev) ! hail number + real(kind_phys), intent(inout) :: chl(:,:) ! (1:ncol,1:nlev) ! hail number real(kind_phys), intent(inout) :: vh(1:ncol,1:nlev) ! graupel volume - real(kind_phys), intent(inout) :: vhl(1:ncol,1:nlev) ! hail volume + real(kind_phys), intent(inout) :: vhl(:,:) ! (1:ncol,1:nlev) ! hail volume ! State variables and timestep information real(kind_phys), intent(inout) :: tgrs(1:ncol,1:nlev) real(kind_phys), intent(in ) :: prsl(1:ncol,1:nlev) @@ -198,13 +344,13 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & real(kind_phys), intent(inout) :: refl_10cm(1:ncol,1:nlev) logical, intent(in ) :: do_radar_ref, first_time_step ! Cloud effective radii - real(kind_phys), optional, intent(inout) :: re_cloud(1:ncol,1:nlev) - real(kind_phys), optional, intent(inout) :: re_ice(1:ncol,1:nlev) - real(kind_phys), optional, intent(inout) :: re_snow(1:ncol,1:nlev) -! real(kind_phys), optional, intent( out) :: re_rain(1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_cloud(:,:) ! (1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_ice(:,:) ! (1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_snow(:,:) ! (1:ncol,1:nlev) + real(kind_phys), optional, intent(inout) :: re_rain(:,:) ! (1:ncol,1:nlev) integer, intent(in) :: imp_physics - integer, intent(in) :: imp_physics_nssl2m, imp_physics_nssl2mccn - logical, intent(in) :: nssl_hail_on, nssl_invertccn + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn integer, intent(in) :: ntccn, ntccna integer, intent(out) :: errflg @@ -223,10 +369,19 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & real(kind_phys) :: qs_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) real(kind_phys) :: qh_mp(1:ncol,1:nlev) !< kg kg-1 (graupel dry mixing ratio) real(kind_phys) :: qhl_mp(1:ncol,1:nlev) !< kg kg-1 (hail dry mixing ratio) + real(kind_phys) :: nc_mp(1:ncol,1:nlev) !< droplet num. conc. + real(kind_phys) :: nr_mp(1:ncol,1:nlev) !< rain num. conc. + real(kind_phys) :: ni_mp(1:ncol,1:nlev) !< ice crystal num. conc. + real(kind_phys) :: ns_mp(1:ncol,1:nlev) !< snow num. conc. + real(kind_phys) :: nh_mp(1:ncol,1:nlev) !< graupel num. conc. + real(kind_phys) :: nhl_mp(1:ncol,1:nlev) !< hail num. conc. real(kind_phys) :: cn_mp(1:ncol,1:nlev) real(kind_phys) :: cna_mp(1:ncol,1:nlev) + real(kind_phys) :: cccn_mp(1:ncol,1:nlev) + real(kind_phys) :: cccna_mp(1:ncol,1:nlev) + real(kind_phys) :: vh_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) ! create temporaries for hail in case it does not exist - real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) + !real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) ! Vertical velocity and level width real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1 @@ -259,9 +414,11 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & real(kind_phys) :: re_cloud_mp(1:ncol,1:nlev) ! m real(kind_phys) :: re_ice_mp(1:ncol,1:nlev) ! m real(kind_phys) :: re_snow_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_rain_mp(1:ncol,1:nlev) ! m integer :: has_reqc integer :: has_reqi integer :: has_reqs + integer :: has_reqr ! Dimensions used in driver integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -273,13 +430,17 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & integer, parameter :: ndebug = 0 logical, parameter :: convertdry = .true. logical :: invertccn + real :: cwmas + real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array errflg = 0 errmsg = '' - IF ( ndebug > 1 ) write(0,*) 'In physics nsslg_run' +! write(0,*) 'nssl_run: nlev,ncol,rank = ',nlev,ncol,mpirank + + IF ( ndebug > 1 ) write(0,*) 'In physics nssl_run' ! Check initialization state @@ -292,6 +453,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & invertccn = nssl_invertccn !> - Convert specific humidity/moist mixing ratios to dry mixing ratios + ! NOTE: Implied loops! qv_mp = spechum/(1.0_kind_phys-spechum) IF ( convertdry ) THEN qc_mp = qc/(1.0_kind_phys-spechum) @@ -299,8 +461,19 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & qi_mp = qi/(1.0_kind_phys-spechum) qs_mp = qs/(1.0_kind_phys-spechum) qh_mp = qh/(1.0_kind_phys-spechum) + + IF ( nssl_ccn_on ) cccn_mp = cccn/(1.0_kind_phys-spechum) +! cccna_mp = cccna/(1.0_kind_phys-spechum) + nc_mp = ccw/(1.0_kind_phys-spechum) + nr_mp = crw/(1.0_kind_phys-spechum) + ni_mp = cci/(1.0_kind_phys-spechum) + ns_mp = csw/(1.0_kind_phys-spechum) + nh_mp = chw/(1.0_kind_phys-spechum) + vh_mp = vh/(1.0_kind_phys-spechum) IF ( nssl_hail_on ) THEN qhl_mp = qhl/(1.0_kind_phys-spechum) + nhl_mp = chl/(1.0_kind_phys-spechum) + vhl_mp = vhl/(1.0_kind_phys-spechum) ENDIF ELSE ! qv_mp = spechum ! /(1.0_kind_phys-spechum) @@ -309,21 +482,48 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & qi_mp = qi ! /(1.0_kind_phys-spechum) qs_mp = qs ! /(1.0_kind_phys-spechum) qh_mp = qh ! /(1.0_kind_phys-spechum) + IF ( nssl_ccn_on ) cccn_mp = cccn +! cccna_mp = cccna + nc_mp = ccw + nr_mp = crw + ni_mp = cci + ns_mp = csw + nh_mp = chw IF ( nssl_hail_on ) THEN qhl_mp = qhl ! /(1.0_kind_phys-spechum) + nhl_mp = chl + vhl_mp = vhl ENDIF ENDIF IF ( nssl_hail_on ) THEN - chl_mp = chl - vhl_mp = vhl +! nhl_mp = chl +! vhl_mp = vhl ELSE qhl_mp = 0 - chl_mp = 0 + nhl_mp = 0 vhl_mp = 0 ENDIF + IF ( .false. ) THEN + write(6,*) 'nsslrun: qc,max ccw = ',mpirank,maxval(qc_mp),maxval(nc_mp),sum(nc_mp) + IF ( mpirank == 1 ) THEN + DO k=1,nlev + DO i=1,ncol + IF ( qc_mp(i,k) > 1.e-6 .and. nc_mp(i,k) <= 1.e-9 ) THEN + write(6,*) 'i,k,qc,nc,ccn = ',i,k,qc_mp(i,k),nc_mp(i,k),cccn_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + ! IF ( first_time_step ) THEN + ! write(0,*) 'mp_nssl_run: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh) + ! write(0,*) 'mp_nssl_run: ni,ns,nh maxval: ',maxval(ni_mp),maxval(ns_mp),maxval(nh_mp) + ! ENDIF + !> - Density of air in kg m-3 rho = prsl/(con_rd*tgrs) @@ -378,11 +578,13 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & has_reqc = 1 has_reqi = 1 has_reqs = 1 + IF ( present( re_rain ) ) has_reqr = 1 else if (.not.present(re_cloud) .and. .not.present(re_ice) .and. .not.present(re_snow)) then do_effective_radii = .false. has_reqc = 0 has_reqi = 0 has_reqs = 0 + has_reqr = 0 else write(errmsg,fmt='(*(a))') 'Logic error in mp_nssl_run:', & ' all or none of the following optional', & @@ -394,6 +596,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & re_cloud_mp = 0 re_ice_mp = 0 re_snow_mp = 0 + re_rain_mp = 0 ! Set internal dimensions ids = 1 @@ -427,26 +630,53 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ENDIF IF ( first_time_step ) THEN - itimestep = 0 - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + itimestep = 0 ! gets incremented to 1 in call loop + IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN - cccn = 0 + cccn_mp = 0 !cccn = nssl_qccn ELSE - cccn = nssl_qccn + cccn_mp = nssl_qccn ENDIF ENDIF ELSE itimestep = 2 ENDIF - - - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + + ! incoming droplet field may have some inconsistent number concentrations (e.g., from PBL) + ! so check for that, otherwise mass may be zapped into vapor + allocate( an(ncol,1,nlev,na) ) + an(:,:,:,:) = 0.0 ! needed for workspace in routine + + cwmas = 1000.*0.523599*(2.*9.e-6)**3 + + call calcnfromq(nx=ncol,ny=1,nz=nlev,an=an,na=na,nor=0,norz=0,dn=rho, & + & qcw=qc_mp,qci=qi_mp, & + & ccw=nc_mp,cci=ni_mp, & + & cccn=cccn_mp,qv=qv_mp, invertccn_flag=nssl_invertccn, cwmasin=cwmas ) + + IF ( .false. ) THEN + write(6,*) 'nsslrun2: qc,max ccw = ',mpirank,maxval(qc_mp),maxval(nc_mp),sum(nc_mp) + IF ( mpirank == 1 ) THEN + DO k=1,nlev + DO i=1,ncol + IF ( qc_mp(i,k) > 1.e-6 .and. nc_mp(i,k) <= 1.e-9 ) THEN + write(6,*) 'i2,k,qc,nc,ccn = ',i,k,qc_mp(i,k),nc_mp(i,k),cccn_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + + deallocate( an ) + + IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN ! cn_mp = Max(0.0, nssl_qccn - Max(0.0,cccn)) DO k = 1,nlev DO i = 1,ncol - cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn(i,k)) ) + cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn_mp(i,k)) ) ! cn_mp(i,k) = Min(nssl_qccn, nssl_qccn - cccn(i,k) ) ENDDO ENDDO @@ -457,7 +687,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ! ENDDO ! ENDDO ELSE - cn_mp = cccn + cn_mp = cccn_mp ENDIF IF ( ntccna > 0 ) THEN ! cna_mp = cccna @@ -473,7 +703,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN CALL nssl_2mom_driver( & @@ -487,13 +717,13 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & QS=qs_mp, & QH=qh_mp, & QHL=qhl_mp, & - CCW=ccw, & - CRW=crw, & - CCI=cci, & - CSW=csw, & - CHW=chw, & - CHL=chl_mp, & - VHW=vh, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & VHL=vhl_mp, & cn=cn_mp, & ! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use @@ -511,12 +741,15 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & dbz = refl_10cm, & ! nssl_progn=.false., & diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & re_cloud=re_cloud_mp, & re_ice=re_ice_mp, & re_snow=re_snow_mp, & + re_rain=re_rain_mp, & has_reqc=has_reqc, & ! ala G. Thompson has_reqi=has_reqi, & ! ala G. Thompson has_reqs=has_reqs, & ! ala G. Thompson + has_reqr=has_reqr, & IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -537,13 +770,13 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & QH=qh_mp, & QHL=qhl_mp, & ! CCW=qnc_mp, & - CCW=ccw, & - CRW=crw, & - CCI=cci, & - CSW=csw, & - CHW=chw, & - CHL=chl_mp, & - VHW=vh, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & VHL=vhl_mp, & ! cn=cccn, & PII=prslk, & @@ -559,12 +792,15 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & dbz = refl_10cm, & ! nssl_progn=.false., & diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & re_cloud=re_cloud_mp, & re_ice=re_ice_mp, & re_snow=re_snow_mp, & + re_rain=re_rain_mp, & has_reqc=has_reqc, & ! ala G. Thompson has_reqi=has_reqi, & ! ala G. Thompson has_reqs=has_reqs, & ! ala G. Thompson + has_reqr=has_reqr, & IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -574,8 +810,8 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & DO i = 1,ncol - delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) - delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) + delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) ! this is liquid equivalent of all precip + delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) ! this is liquid equivalent of graupel delta_ice_mp(i) = delta_ice_mp(i) + xdelta_ice_mp(i) delta_snow_mp(i) = delta_snow_mp(i) + xdelta_snow_mp(i) ENDDO @@ -583,17 +819,17 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ENDDO - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN !cccn = Max(0.0, nssl_qccn - cn_mp ) DO k = 1,nlev DO i = 1,ncol ! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) - cccn(i,k) = nssl_qccn - cn_mp(i,k) + cccn_mp(i,k) = nssl_qccn - cn_mp(i,k) ENDDO ENDDO ELSE - cccn = cn_mp + cccn_mp = cn_mp ENDIF ! cccna = cna_mp ENDIF @@ -619,7 +855,7 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ENDIF write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) IF ( 1000.*maxval(qc_mp) > 0.5 .or. 1000.*maxval(qi_mp) > 0.09 .or. 1000.*maxval(qs_mp) > 0.1 ) THEN - IF ( imp_physics == imp_physics_nssl2mccn ) THEN + IF ( nssl_ccn_on ) THEN write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' DO k = 1,nlev write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, ccw(1,k)*rho(1,k)*1.e-6, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 @@ -633,10 +869,6 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & ENDIF ENDIF - IF ( nssl_hail_on ) THEN - chl = chl_mp - vhl = vhl_mp - ENDIF !> - Convert dry mixing ratios to specific humidity/moist mixing ratios spechum = qv_mp/(1.0_kind_phys+qv_mp) @@ -646,8 +878,18 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & qi = qi_mp/(1.0_kind_phys+qv_mp) qs = qs_mp/(1.0_kind_phys+qv_mp) qh = qh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_ccn_on ) cccn = cccn_mp/(1.0_kind_phys+qv_mp) +! cccna = cccna_mp/(1.0_kind_phys+qv_mp) + ccw = nc_mp/(1.0_kind_phys+qv_mp) + crw = nr_mp/(1.0_kind_phys+qv_mp) + cci = ni_mp/(1.0_kind_phys+qv_mp) + csw = ns_mp/(1.0_kind_phys+qv_mp) + chw = nh_mp/(1.0_kind_phys+qv_mp) + vh = vh_mp/(1.0_kind_phys+qv_mp) IF ( nssl_hail_on ) THEN qhl = qhl_mp/(1.0_kind_phys+qv_mp) + chl = nhl_mp/(1.0_kind_phys+qv_mp) + vhl = vhl_mp/(1.0_kind_phys+qv_mp) ENDIF ELSE ! spechum = qv_mp ! /(1.0_kind_phys+qv_mp) @@ -656,13 +898,23 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & qi = qi_mp ! /(1.0_kind_phys+qv_mp) qs = qs_mp ! /(1.0_kind_phys+qv_mp) qh = qh_mp ! /(1.0_kind_phys+qv_mp) + IF ( nssl_ccn_on ) cccn = cccn_mp +! cccna = cccna_mp + ccw = nc_mp + crw = nr_mp + cci = ni_mp + csw = ns_mp + chw = nh_mp + vh = vh_mp IF ( nssl_hail_on ) THEN qhl = qhl_mp ! /(1.0_kind_phys+qv_mp) + chl = nhl_mp + vhl = vhl_mp ENDIF ENDIF -! write(0,*) 'mp_nsslg: done q' +! write(0,*) 'mp_nssl: done q' !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables ! "rain" in NSSL MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) @@ -673,27 +925,27 @@ subroutine mp_nsslg_run(ncol, nlev, con_g, con_rd, & snow = max(0.0, delta_snow_mp/1000.0_kind_phys) rain = max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) -! write(0,*) 'mp_nsslg: done precip' +! write(0,*) 'mp_nssl: done precip' if (do_effective_radii) then ! Convert m to micron re_cloud = re_cloud_mp*1.0E6_kind_phys re_ice = re_ice_mp*1.0E6_kind_phys re_snow = re_snow_mp*1.0E6_kind_phys -! re_rain = 1.0E3_kind_phys + re_rain = re_rain_mp*1.0E6_kind_phys end if - IF ( ndebug > 1 ) write(0,*) 'mp_nsslg: end' + IF ( ndebug > 1 ) write(0,*) 'mp_nssl: end' - end subroutine mp_nsslg_run + end subroutine mp_nssl_run !>@} #if 0 -!! \section arg_table_mp_nsslg_finalize Argument Table -!! \htmlinclude mp_nsslg_finalize.html +!! \section arg_table_mp_nssl_finalize Argument Table +!! \htmlinclude mp_nssl_finalize.html !! #endif - subroutine mp_nsslg_finalize(errflg, errmsg) + subroutine mp_nssl_finalize(errflg, errmsg) implicit none character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -702,6 +954,6 @@ subroutine mp_nsslg_finalize(errflg, errmsg) errmsg = '' - end subroutine mp_nsslg_finalize + end subroutine mp_nssl_finalize -end module mp_nsslg +end module mp_nssl diff --git a/physics/mp_nsslg.meta b/physics/mp_nssl.meta similarity index 69% rename from physics/mp_nsslg.meta rename to physics/mp_nssl.meta index 95a11826e..78914eb91 100644 --- a/physics/mp_nsslg.meta +++ b/physics/mp_nssl.meta @@ -1,10 +1,10 @@ [ccpp-table-properties] - name = mp_nsslg + name = mp_nssl type = scheme dependencies = machine.F,module_mp_nssl_2mom.F90 [ccpp-arg-table] - name = mp_nsslg_init + name = mp_nssl_init type = scheme [ncol] standard_name = horizontal_loop_extent @@ -22,6 +22,39 @@ type = integer intent = in optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F +[threads] + standard_name = omp_threads + long_name = number of OpenMP threads available to scheme + units = count + dimensions = () + type = integer + intent = in + optional = F +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in + optional = F [mpicomm] standard_name = mpi_comm long_name = MPI communicator @@ -46,14 +79,6 @@ type = integer intent = in optional = F -[threads] - standard_name = omp_threads - long_name = number of OpenMP threads available to scheme - units = count - dimensions = () - type = integer - intent = in - optional = F [imp_physics] standard_name = flag_for_microphysics_scheme long_name = choice of microphysics scheme @@ -62,7 +87,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -70,14 +95,6 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [nssl_cccn] standard_name = nssl_ccn_concentration long_name = CCN concentration @@ -105,6 +122,14 @@ kind = kind_phys intent = in optional = F +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none + dimensions = () + type = logical + intent = in + optional = F [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro @@ -113,27 +138,213 @@ type = logical intent = in optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro units = none dimensions = () - type = character - kind = len=* - intent = out + type = logical + intent = in optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) units = flag dimensions = () - type = integer - intent = out + type = logical + intent = in + optional = F +[spechum] + standard_name = water_vapor_specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qc] + standard_name = cloud_condensed_water_mixing_ratio + long_name = cloud water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qr] + standard_name = rain_water_mixing_ratio + long_name = rain water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qi] + standard_name = ice_water_mixing_ratio + long_name = ice water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qs] + standard_name = snow_water_mixing_ratio + long_name = snow water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qh] + standard_name = graupel_mixing_ratio + long_name = graupel mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qhl] + standard_name = hail_mixing_ratio + long_name = moist (dry+vapor, no condensates) mixing ratio of hail + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cccn] + standard_name = cloud_condensation_nuclei_number_concentration + long_name = number concentration of cloud condensation nuclei + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cccna] + standard_name = activated_cloud_condensation_nuclei_number_concentration + long_name = number concentration of activated cloud condensation nuclei + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ccw] + standard_name = cloud_droplet_number_concentration + long_name = cloud droplet number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[crw] + standard_name = rain_number_concentration + long_name = rain number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cci] + standard_name = ice_number_concentration + long_name = ice number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[csw] + standard_name = snow_number_concentration + long_name = snow number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[chw] + standard_name = graupel_number_concentration + long_name = graupel number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[chl] + standard_name = hail_number_concentration + long_name = hail number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[vh] + standard_name = graupel_volume + long_name = graupel particle volume + units = m3 kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[vhl] + standard_name = hail_volume + long_name = hail particle volume + units = m3 kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[csw_phys] + standard_name = snow_number_concentration_updated_by_physics + long_name = snow number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout optional = F ######################################################################## [ccpp-arg-table] - name = mp_nsslg_run + name = mp_nssl_run type = scheme [ncol] standard_name = horizontal_loop_extent @@ -169,6 +380,14 @@ kind = kind_phys intent = in optional = F +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F [spechum] standard_name = water_vapor_specific_humidity_updated_by_physics long_name = water vapor specific humidity @@ -480,6 +699,15 @@ kind = kind_phys intent = out optional = T +[re_rain] + standard_name = effective_radius_of_stratiform_cloud_rain_particle_in_um + long_name = effective radius of cloud rain particle in micrometers + units = um + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = T [imp_physics] standard_name = flag_for_microphysics_scheme long_name = choice of microphysics scheme @@ -488,7 +716,7 @@ type = integer intent = in optional = F -[imp_physics_nssl2m] +[imp_physics_nssl] standard_name = flag_for_nssl2m_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag @@ -496,12 +724,12 @@ type = integer intent = in optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = none dimensions = () - type = integer + type = logical intent = in optional = F [nssl_hail_on] @@ -556,7 +784,7 @@ ######################################################################## [ccpp-arg-table] - name = mp_nsslg_finalize + name = mp_nssl_finalize type = scheme [errmsg] standard_name = ccpp_error_message From 5b9596487d2af88b518b8ab3c0e6a9b29caa60ac Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 1 Oct 2021 18:03:37 -0500 Subject: [PATCH 046/217] Fixed missing setting of save arrays for NSSL. --- physics/GFS_suite_interstitial.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 2351dc992..27323d73e 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -671,10 +671,12 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & else if (imp_physics == imp_physics_nssl ) then do k=1,levs do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! ice - clw(i,k,2) = gq0(i,k,ntcw) ! water + clw(i,k,1) = gq0(i,k,ntiw) ! cloud ice + clw(i,k,2) = gq0(i,k,ntcw) ! cloud droplets enddo enddo + save_qi(:,:) = clw(:,:,1) + save_qc(:,:) = clw(:,:,2) elseif (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_mg .or. imp_physics == imp_physics_fer_hires) then do k=1,levs do i=1,im @@ -867,8 +869,8 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo enddo - if ( .true. .and. ( imp_physics == imp_physics_nssl ) ) then - liqm = con_pi/6.*1.e3*(40.e-6)**3 ! 4./3.*con_pi*1.e-12 + if ( imp_physics == imp_physics_nssl ) then + liqm = con_pi/6.*1.e3*(18.e-6)**3 ! 4./3.*con_pi*1.e-12 icem = con_pi/6.*1.e3*(120.e-6)**3 ! 4./3.*con_pi*3.2768*1.e-14*890. ! qccn = nssl_cccn/1.225 do k=1,levs From 6920e48ff07ff634f11072f676751d48e747bd02 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 14 Oct 2021 20:28:27 -0500 Subject: [PATCH 047/217] Update to newer base code plus some cleanup of NSSL microphysics --- physics/GFS_DCNV_generic.F90 | 9 +- physics/GFS_DCNV_generic.meta | 32 +++++ physics/GFS_MP_generic.meta | 2 +- physics/GFS_PBL_generic.F90 | 6 +- physics/GFS_PBL_generic.meta | 24 ++-- physics/GFS_debug.F90 | 2 +- physics/GFS_rrtmg_pre.F90 | 14 +- physics/GFS_rrtmg_pre.meta | 14 +- physics/GFS_suite_interstitial.F90 | 9 +- physics/GFS_suite_interstitial.meta | 13 +- physics/maximum_hourly_diagnostics.meta | 2 +- physics/module_MYNNPBL_wrapper.meta | 2 +- physics/module_mp_nssl_2mom.F90 | 28 ++-- physics/mp_nssl.F90 | 20 +-- physics/mp_nssl.meta | 173 +++++++++++------------- physics/sfc_drv_ruc.F90 | 7 +- physics/sfc_drv_ruc.meta | 8 ++ 17 files changed, 204 insertions(+), 161 deletions(-) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index e7dec5ca1..fb807c3ca 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -19,7 +19,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc gu0, gv0, gt0, gq0, nsamftrac, ntqv, & save_u, save_v, save_t, save_q, clw, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, cscnv, satmedmf, trans_trac, ras, ntrac, & + ntgnc, nthl, nthnc, nthv, ntgv, & + cscnv, satmedmf, trans_trac, ras, ntrac, & dtidx, index_of_process_dcnv, errmsg, errflg) use machine, only: kind_phys @@ -27,7 +28,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc implicit none integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 @@ -71,7 +72,9 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & + n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntgv ) then tracers = tracers + 1 if(dtidx(100+n,index_of_process_dcnv)>0) then save_q(:,:,n) = clw(:,:,tracers) diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index c719ae96c..4703406c9 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -232,6 +232,38 @@ dimensions = () type = integer intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index b5a6a43fb..f10b02948 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -214,7 +214,7 @@ type = integer intent = in [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 15246546e..aae7d72ec 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -113,7 +113,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: cplchm, ltaerosol, nssl_hail_on, nssl_ccn_on + logical, intent(in) :: nssl_hail_on, nssl_ccn_on real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs @@ -413,10 +413,12 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, integer, parameter :: kp = kind_phys integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm, kdt integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires - integer, intent(in) :: imp_physics_nssl, nssl_ccn_on, nssl_hail_on + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_ccn_on, nssl_hail_on logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 2f1cbdec6..eeb68c74f 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -183,7 +183,7 @@ type = integer intent = in [ntccn] - standard_name = index_for_cloud_condensation_nuclei_number_concentration + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration units = index dimensions = () @@ -191,7 +191,7 @@ intent = in optional = F [nthl] - standard_name = index_for_hail + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array long_name = tracer index for hail units = index dimensions = () @@ -199,7 +199,7 @@ intent = in optional = F [nthnc] - standard_name = index_for_hail_number_concentration + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array long_name = tracer index for hail number concentration units = index dimensions = () @@ -207,7 +207,7 @@ intent = in optional = F [ntgv] - standard_name = index_for_graupel_volume + standard_name = index_of_graupel_volume_in_tracer_concentration_array long_name = tracer index for graupel particle volume units = index dimensions = () @@ -215,7 +215,7 @@ intent = in optional = F [nthv] - standard_name = index_for_hail_volume + standard_name = index_of_hail_volume_in_tracer_concentration_array long_name = tracer index for hail particle volume units = index dimensions = () @@ -272,7 +272,7 @@ type = integer intent = in [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () @@ -618,7 +618,7 @@ type = integer intent = in [ntccn] - standard_name = index_for_cloud_condensation_nuclei_number_concentration + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration units = index dimensions = () @@ -626,7 +626,7 @@ intent = in optional = F [nthl] - standard_name = index_for_hail + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array long_name = tracer index for hail units = index dimensions = () @@ -634,7 +634,7 @@ intent = in optional = F [nthnc] - standard_name = index_for_hail_number_concentration + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array long_name = tracer index for hail number concentration units = index dimensions = () @@ -642,7 +642,7 @@ intent = in optional = F [ntgv] - standard_name = index_for_graupel_volume + standard_name = index_of_graupel_volume_in_tracer_concentration_array long_name = tracer index for graupel particle volume units = index dimensions = () @@ -650,7 +650,7 @@ intent = in optional = F [nthv] - standard_name = index_for_hail_volume + standard_name = index_of_hail_volume_in_tracer_concentration_array long_name = tracer index for hail particle volume units = index dimensions = () @@ -707,7 +707,7 @@ type = integer intent = in [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 027a0c523..28289a1c4 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1375,7 +1375,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clxss ', Interstitial%clxss ) end if ! GFDL and Thompson MP - if (Model%imp_physics == Model%imp_physics_gfdl .or. Model%imp_physics == Model%imp_physics_thompson) then + if (Model%imp_physics == Model%imp_physics_gfdl .or. Model%imp_physics == Model%imp_physics_thompson .or. Model%imp_physics == Model%imp_physics_nssl) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%graupelmp ', Interstitial%graupelmp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%icemp ', Interstitial%icemp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rainmp ', Interstitial%rainmp ) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 10ba643bd..99dc215b3 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,9 +18,9 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, first_time_step, & - imp_physics,imp_physics_nssl, & + imp_physics,imp_physics_nssl, nssl_ccn_on, nssl_invertccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & imp_physics_fer_hires, julian, yearlen, lndp_var_list, lsswr, lslwr, & @@ -78,7 +78,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & make_DropletNumber, & make_RainNumber - use module_mp_nssl_2mom, only: calc_eff_radius, calcnfromq, na +! use module_mp_nssl_2mom, only: calc_eff_radius, calcnfromq, na implicit none @@ -686,11 +686,13 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif if_thompson if (imp_physics == imp_physics_nssl) then ! write(6,*) 'rrtm_pre: set qx_mp for NSSL',ntlnc,ntinc,ntsnc,ntrnc + IF ( .not. effr_in ) THEN do k=1,LMK ! IF ( me == mpiroot ) write(6,*) 'k,rho: ',k,rho(1,k) do i=1,IM qvs = qgrs(i,k,ntqv) qv_mp (i,k) = qvs/(1.-qvs) + rho (i,k) = con_eps*plyr(i,k)*100./(con_rd*tlyr(i,k)*(qv_mp(i,k)+con_eps)) qc_mp (i,k) = tracer1(i,k,ntcw)/(1.-qvs) qi_mp (i,k) = tracer1(i,k,ntiw)/(1.-qvs) qs_mp (i,k) = tracer1(i,k,ntsw)/(1.-qvs) @@ -702,6 +704,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & IF ( nssl_ccn_on ) cccn_mp(i,k) = tracer1(i,k,ntccn)/(1.-qvs) enddo enddo + ENDIF ! write(6,*) 'rrtmg_pre: max qctrac,qc,qcphy,nctrac,ccw,ccwphy: ',maxval(qc_mp),maxval(qc), & ! maxval(qc_phys),maxval(nc_mp),maxval(ccw),maxval(ccw_phys) ! write(6,*) 'rrtmg_pre: max ni,ns,nr = ',maxval(ni_mp),maxval(ns_mp),maxval(nr_mp) @@ -803,8 +806,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & elseif (imp_physics == imp_physics_nssl ) then ! NSSL MP cldcov = 0.0 if(effr_in) then -! if( kdt > 2 ) then -! IF ( .true. .or. maxval(nc_mp) >= 1.e-20 ) THEN do k=1,lm k1 = k + kd do i=1,im @@ -815,6 +816,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo else +#if 0 ! calculate radii here, but something is not right with incoming number concentrations ! IF ( .true. .and. first_time_step ) THEN IF ( ( maxval(qc_mp) > 1.e-11 .and. maxval(nc_mp) < 1.e-5 ) .or. & @@ -905,7 +907,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & effrs_inout(i,k) = effrs(i,k1) enddo enddo - +#endif endif elseif (imp_physics == imp_physics_thompson) then ! Thompson MP diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 4a9a70efe..f0f178187 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1,7 +1,7 @@ [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 = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,module_mp_radar.F90,module_mp_thompson.F90,module_mp_nssl_2mom.F90 dependencies = module_mp_thompson_make_number_concentrations.F90,physcons.F90,physparam.f,radcons.f90,radiation_aerosols.f dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90,radiation_cloud_overlap.F90 @@ -143,7 +143,7 @@ type = integer intent = in [ntrnc] - standard_name = index_for_rain_number_concentration + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array long_name = tracer index for rain number concentration units = index dimensions = () @@ -151,7 +151,7 @@ intent = in optional = F [ntsnc] - standard_name = index_for_snow_number_concentration + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array long_name = tracer index for snow number concentration units = index dimensions = () @@ -180,7 +180,7 @@ type = integer intent = in [nthl] - standard_name = index_for_hail + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array long_name = tracer index for hail units = index dimensions = () @@ -188,7 +188,7 @@ intent = in optional = F [ntccn] - standard_name = index_for_cloud_condensation_nuclei_number_concentration + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration units = index dimensions = () @@ -268,7 +268,7 @@ type = integer intent = in [first_time_step] - standard_name = flag_for_first_time_step + standard_name = flag_for_first_timestep long_name = flag for first time step for time integration loop (cold/warmstart) units = flag dimensions = () @@ -299,7 +299,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 27323d73e..7bd9ea010 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -713,12 +713,11 @@ end subroutine GFS_suite_interstitial_4_finalize !! \htmlinclude GFS_suite_interstitial_4_run.html !! subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & - ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_nssl, nssl_invertccn, nssl_ccn_on, nssl_invertccn, & + ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl, nssl_invertccn, nssl_ccn_on, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & - qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) - otsptflag, ntracp1, errmsg, errflg) + qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, ntracp1, errmsg, errflg) use machine, only: kind_phys use module_mp_nssl_2mom, only: qccn @@ -732,7 +731,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr logical, intent(in) :: otsptflag(1:ntracp1)! on/off switch for tracer transport by updraft and integer, intent(in) :: ntracp1 integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & - ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl logical, intent(in) :: ltaerosol, convert_dry_rho diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 9886a51a3..dc9044243 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_rad_reset type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90,module_mp_nssl_2mom.F90 ######################################################################## [ccpp-arg-table] @@ -1271,7 +1271,7 @@ type = integer intent = in [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () @@ -1629,7 +1629,7 @@ type = integer intent = in [ntccn] - standard_name = index_for_cloud_condensation_nuclei_number_concentration + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration units = index dimensions = () @@ -1678,13 +1678,8 @@ dimensions = () type = logical intent = in -<<<<<<< HEAD -[imp_physics_nssl2m] -======= - optional = F [imp_physics_nssl] ->>>>>>> 9d0fcbd1 ( - Changed from two imp_physics_nssl flags to a single one with second flag for nssl_ccn_on) - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 0cf6ed5b4..48fb74b1f 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -64,7 +64,7 @@ type = integer intent = in [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 8e60f953a..4516803f0 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1276,7 +1276,7 @@ type = integer intent = in [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 0a8532de1..65fecae7e 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1,7 +1,7 @@ !WRF:MODEL_LAYER:PHYSICS -! prepocessed on "Sep 30 2021" at "11:13:44" +! prepocessed on "Oct 6 2021" at "17:14:05" @@ -214,7 +214,7 @@ MODULE module_mp_nssl_2mom integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) ! =2 turn on for graupel density less than 300. only integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) - integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band + integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband ! microphysics real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params @@ -1248,7 +1248,7 @@ SUBROUTINE nssl_2mom_init( & - IF ( .true. ) THEN ! set to true to enable internal namelist read + IF ( .false. ) THEN ! set to true to enable internal namelist read open(15,file='input.nml',status='old',form='formatted',action='read') rewind(15) read(15,NML=nssl_mp_params,iostat=istat) @@ -2832,7 +2832,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present(has_reqr) .and. present( re_rain ) ) THEN IF ( has_reqr /= 0 ) THEN - re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t3(ix,1,kz), 2999.E-6)) + DO kz = kts,kte + DO ix = its,ite + re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t4(ix,1,kz), 2999.E-6)) + ENDDO + ENDDO ENDIF ENDIF @@ -3786,13 +3790,17 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO n = 1,ndfall - IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN + IF ( ( il /= lc .and. il /= li ) .and. do_accurate_sedimentation .and. n .ge. 2 .and. & + ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN ! ! zero the precip flux arrays (2d) ! ! xvt(:,:,:,il) = 0.0 dummy = 0.d0 + + IF ( il == lh .or. il == lr ) xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & & xvt, rhovtzx, & & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & @@ -6395,7 +6403,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! DO il = lc,lhab ! IF ( il .ne. lr ) THEN DO mgs = 1,ngscnt - vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + IF ( ildo == 0 .or. ildo == lc ) THEN + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + ENDIF IF ( li .gt. 1 ) THEN ! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) ! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) @@ -7774,8 +7784,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & if (lsw .gt. 1) THEN qxw = an(ix,jy,kz,lsw) qxw1 = 0.0 - ELSEIF ( iusewetsnow == 1 .and. temk(ix,jy,kz) .gt. tfr+1. .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) & - & .and. an(ix,jy,kz,lr) > qsmin) THEN + ELSEIF ( ( iusewetsnow == 1 .or. iusewetsnow == 3) .and. temk(ix,jy,kz) .gt. tfr+1. & + & .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) .and. an(ix,jy,kz,lr) > qsmin) THEN qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr)) qxw1 = qxw ENDIF @@ -7786,7 +7796,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN ! IF ( .true. ) THEN - IF ( qxw > qsmin ) THEN ! old version + IF ( qxw > qsmin .or. iusewetsnow >= 2) THEN ! old version ! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & ! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 84531244e..2e90dfaab 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -24,13 +24,13 @@ module mp_nssl !! \htmlinclude mp_nssl_init.html !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & - mpicomm, mpirank, mpiroot, & + mpirank, mpiroot, & imp_physics, imp_physics_nssl, & nssl_cccn, nssl_alphah, nssl_alphahl, & nssl_ccn_on, nssl_hail_on, nssl_invertccn, first_time_step, & spechum, qc, qr, qi, qs, qh, qhl, & - cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl, & - csw_phys ) + cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl ) + use module_mp_nssl_2mom, only: nssl_2mom_init, calcnfromq, na use physcons, only: con_rd @@ -44,7 +44,6 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent(in) :: threads logical, intent(in) :: restart - integer, intent(in) :: mpicomm integer, intent(in) :: mpirank integer, intent(in) :: mpiroot integer, intent(in) :: imp_physics @@ -72,8 +71,6 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & real(kind_phys), intent(inout) :: vh(1:ncol,1:nlev) ! graupel volume real(kind_phys), intent(inout) :: vhl(:,:) ! (1:ncol,1:nlev) ! hail volume - real(kind_phys), intent(inout) :: csw_phys(1:ncol,1:nlev) - ! State variables and timestep information real(kind_phys), intent(inout) :: tgrs(1:ncol,1:nlev) real(kind_phys), intent(in ) :: prsl(1:ncol,1:nlev) @@ -188,6 +185,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ENDIF ! .not. is_initialized +#if 0 ! IF ( is_initialized .and. ((.not. first_time_step) .or. restart ) ) THEN ! return ! ENDIF @@ -260,7 +258,6 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & cccn = cccn_mp ENDIF ENDIF - csw_phys = csw ! qs = 0 ! qi = 0 @@ -277,6 +274,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & deallocate( an ) +#endif return @@ -425,7 +423,7 @@ 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 = 300. ! 600. ! 120. + real, parameter :: dtpmax = 150. ! 300. ! 600. ! 120. real(kind_phys) :: dtptmp integer, parameter :: ndebug = 0 logical, parameter :: convertdry = .true. @@ -643,6 +641,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & itimestep = 2 ENDIF + IF ( .false. ) THEN ! incoming droplet field may have some inconsistent number concentrations (e.g., from PBL) ! so check for that, otherwise mass may be zapped into vapor allocate( an(ncol,1,nlev,na) ) @@ -670,6 +669,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & deallocate( an ) + ENDIF IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN @@ -696,7 +696,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ENDIF ENDIF - + IF ( .true. ) THEN DO n = 1,ntmul itimestep = itimestep + 1 @@ -817,6 +817,8 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ENDDO ENDDO + + ENDIF IF ( nssl_ccn_on ) THEN diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 78914eb91..772ba406b 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -7,15 +7,15 @@ name = mp_nssl_init type = scheme [ncol] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent + standard_name = horizontal_dimension + long_name = horizontal dimension units = count dimensions = () type = integer intent = in optional = F [nlev] - standard_name = vertical_dimension + standard_name = vertical_layer_dimension long_name = number of vertical levels units = count dimensions = () @@ -40,7 +40,7 @@ intent = out optional = F [threads] - standard_name = omp_threads + standard_name = number_of_openmp_threads long_name = number of OpenMP threads available to scheme units = count dimensions = () @@ -55,14 +55,6 @@ type = logical intent = in optional = F -[mpicomm] - standard_name = mpi_comm - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in - optional = F [mpirank] standard_name = mpi_rank long_name = current MPI-rank @@ -80,7 +72,7 @@ intent = in optional = F [imp_physics] - standard_name = flag_for_microphysics_scheme + standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme units = flag dimensions = () @@ -88,7 +80,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () @@ -147,7 +139,7 @@ intent = in optional = F [first_time_step] - standard_name = flag_for_first_time_step + standard_name = flag_for_first_timestep long_name = flag for first time step for time integration loop (cold/warmstart) units = flag dimensions = () @@ -155,46 +147,46 @@ intent = in optional = F [spechum] - standard_name = water_vapor_specific_humidity + standard_name = specific_humidity long_name = water vapor specific humidity units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [qc] - standard_name = cloud_condensed_water_mixing_ratio + standard_name = cloud_liquid_water_mixing_ratio long_name = cloud water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [qr] - standard_name = rain_water_mixing_ratio + standard_name = rain_mixing_ratio long_name = rain water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [qi] - standard_name = ice_water_mixing_ratio + standard_name = cloud_ice_mixing_ratio long_name = ice water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [qs] - standard_name = snow_water_mixing_ratio + standard_name = snow_mixing_ratio long_name = snow water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -203,7 +195,7 @@ standard_name = graupel_mixing_ratio long_name = graupel mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -212,7 +204,7 @@ standard_name = hail_mixing_ratio long_name = moist (dry+vapor, no condensates) mixing ratio of hail units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -221,7 +213,7 @@ standard_name = cloud_condensation_nuclei_number_concentration long_name = number concentration of cloud condensation nuclei units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -230,61 +222,61 @@ standard_name = activated_cloud_condensation_nuclei_number_concentration long_name = number concentration of activated cloud condensation nuclei units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [ccw] - standard_name = cloud_droplet_number_concentration + standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air long_name = cloud droplet number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [crw] - standard_name = rain_number_concentration + standard_name = mass_number_concentration_of_rain_water_in_air long_name = rain number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [cci] - standard_name = ice_number_concentration + standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air long_name = ice number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [csw] - standard_name = snow_number_concentration + standard_name = mass_number_concentration_of_snow_in_air long_name = snow number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [chw] - standard_name = graupel_number_concentration + standard_name = mass_number_concentration_of_graupel_in_air long_name = graupel number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [chl] - standard_name = hail_number_concentration + standard_name = mass_number_concentration_of_hail_in_air long_name = hail number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -293,7 +285,7 @@ standard_name = graupel_volume long_name = graupel particle volume units = m3 kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -302,7 +294,7 @@ standard_name = hail_volume long_name = hail particle volume units = m3 kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout @@ -311,36 +303,29 @@ standard_name = air_temperature long_name = model layer mean temperature units = K - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = inout optional = F [prslk] - standard_name = dimensionless_exner_function_at_model_layers + standard_name = dimensionless_exner_function long_name = dimensionless Exner function at model layer centers units = none - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + intent = in + optional = F [prsl] standard_name = air_pressure long_name = mean layer pressure units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in optional = F -[csw_phys] - standard_name = snow_number_concentration_updated_by_physics - long_name = snow number concentration - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F ######################################################################## [ccpp-arg-table] @@ -355,7 +340,7 @@ intent = in optional = F [nlev] - standard_name = vertical_dimension + standard_name = vertical_layer_dimension long_name = number of vertical levels units = count dimensions = () @@ -372,7 +357,7 @@ intent = in optional = F [con_rd] - standard_name = gas_constant_dry_air + standard_name = gas_constant_of_dry_air long_name = ideal gas constant for dry air units = J kg-1 K-1 dimensions = () @@ -389,7 +374,7 @@ intent = in optional = F [spechum] - standard_name = water_vapor_specific_humidity_updated_by_physics + standard_name = specific_humidity_of_new_state long_name = water vapor specific humidity units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -398,7 +383,7 @@ intent = inout optional = F [qc] - standard_name = cloud_condensed_water_mixing_ratio_updated_by_physics + standard_name = cloud_liquid_water_mixing_ratio_of_new_state long_name = cloud water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -407,7 +392,7 @@ intent = inout optional = F [qr] - standard_name = rain_water_mixing_ratio_updated_by_physics + standard_name = rain_mixing_ratio_of_new_state long_name = rain water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -416,7 +401,7 @@ intent = inout optional = F [qi] - standard_name = ice_water_mixing_ratio_updated_by_physics + standard_name = cloud_ice_mixing_ratio_of_new_state long_name = ice water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -425,7 +410,7 @@ intent = inout optional = F [qs] - standard_name = snow_water_mixing_ratio_updated_by_physics + standard_name = snow_mixing_ratio_of_new_state long_name = snow water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -434,7 +419,7 @@ intent = inout optional = F [qh] - standard_name = graupel_mixing_ratio_updated_by_physics + standard_name = graupel_mixing_ratio_of_new_state long_name = graupel mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -443,7 +428,7 @@ intent = inout optional = F [qhl] - standard_name = hail_mixing_ratio_updated_by_physics + standard_name = hail_mixing_ratio_of_new_state long_name = moist (dry+vapor, no condensates) mixing ratio of hail updated by physics units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -452,7 +437,7 @@ intent = inout optional = F [cccn] - standard_name = cloud_condensation_nuclei_number_concentration_updated_by_physics + standard_name = cloud_condensation_nuclei_number_concentration_of_new_state long_name = number concentration of cloud condensation nuclei updated by physics units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -461,7 +446,7 @@ intent = inout optional = F [cccna] - standard_name = activated_cloud_condensation_nuclei_number_concentration_updated_by_physics + standard_name = activated_cloud_condensation_nuclei_number_concentration_of_new_state long_name = number concentration of activated cloud condensation nuclei updated by physics units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -470,7 +455,7 @@ intent = inout optional = F [ccw] - standard_name = cloud_droplet_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air_of_new_state long_name = cloud droplet number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -479,7 +464,7 @@ intent = inout optional = F [crw] - standard_name = rain_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_rain_of_new_state long_name = rain number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -488,7 +473,7 @@ intent = inout optional = F [cci] - standard_name = ice_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air_of_new_state long_name = ice number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -497,7 +482,7 @@ intent = inout optional = F [csw] - standard_name = snow_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_snow_of_new_state long_name = snow number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -506,7 +491,7 @@ intent = inout optional = F [chw] - standard_name = graupel_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_graupel_of_new_state long_name = graupel number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -515,7 +500,7 @@ intent = inout optional = F [chl] - standard_name = hail_number_concentration_updated_by_physics + standard_name = mass_number_concentration_of_hail_of_new_state long_name = hail number concentration units = kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -524,7 +509,7 @@ intent = inout optional = F [vh] - standard_name = graupel_volume_updated_by_physics + standard_name = graupel_volume_of_new_state long_name = graupel particle volume units = m3 kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -533,7 +518,7 @@ intent = inout optional = F [vhl] - standard_name = hail_volume_updated_by_physics + standard_name = hail_volume_of_new_state long_name = hail particle volume units = m3 kg-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -542,21 +527,23 @@ intent = inout optional = F [tgrs] - standard_name = air_temperature_updated_by_physics + standard_name = air_temperature_of_new_state long_name = model layer mean temperature units = K - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout optional = F [prslk] - standard_name = dimensionless_exner_function_at_model_layers + standard_name = dimensionless_exner_function long_name = dimensionless Exner function at model layer centers units = none dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + intent = in + optional = F [prsl] standard_name = air_pressure long_name = mean layer pressure @@ -576,7 +563,7 @@ intent = in optional = F [omega] - standard_name = omega + standard_name = lagrangian_tendency_of_air_pressure long_name = layer mean vertical velocity units = Pa s-1 dimensions = (horizontal_loop_extent,vertical_dimension) @@ -585,7 +572,7 @@ intent = in optional = F [dtp] - standard_name = time_step_for_physics + standard_name = timestep_for_physics long_name = physics timestep units = s dimensions = () @@ -665,7 +652,7 @@ intent = in optional = F [first_time_step] - standard_name = flag_for_first_time_step + standard_name = flag_for_first_timestep long_name = flag for first time step for time integration loop (cold/warmstart) units = flag dimensions = () @@ -673,34 +660,34 @@ intent = in optional = F [re_cloud] - standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle_in_um + standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle long_name = eff. radius of cloud liquid water particle in micrometer units = um - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = T [re_ice] - standard_name = effective_radius_of_stratiform_cloud_ice_particle_in_um + standard_name = effective_radius_of_stratiform_cloud_ice_particle long_name = eff. radius of cloud ice water particle in micrometer units = um dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = T [re_snow] - standard_name = effective_radius_of_stratiform_cloud_snow_particle_in_um + standard_name = effective_radius_of_stratiform_cloud_snow_particle long_name = effective radius of cloud snow particle in micrometer units = um dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = T [re_rain] - standard_name = effective_radius_of_stratiform_cloud_rain_particle_in_um + standard_name = effective_radius_of_stratiform_cloud_rain_particle long_name = effective radius of cloud rain particle in micrometers units = um dimensions = (horizontal_loop_extent,vertical_dimension) @@ -709,7 +696,7 @@ intent = inout optional = T [imp_physics] - standard_name = flag_for_microphysics_scheme + standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme units = flag dimensions = () @@ -717,7 +704,7 @@ intent = in optional = F [imp_physics_nssl] - standard_name = flag_for_nssl2m_microphysics_scheme + standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme units = flag dimensions = () @@ -749,7 +736,7 @@ intent = in optional = F [ntccn] - standard_name = index_for_cloud_condensation_nuclei_number_concentration + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration units = index dimensions = () @@ -757,7 +744,7 @@ intent = in optional = F [ntccna] - standard_name = index_for_activated_cloud_condensation_nuclei_number_concentration + standard_name = index_of_activated_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for activated cloud condensation nuclei number concentration units = index dimensions = () diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 6ab5c1c73..14ec0283a 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -320,6 +320,7 @@ end subroutine lsm_ruc_finalize subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & + & imp_physics_nssl, & & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, zs, & & t1, q1, qc, stype, vtype, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, lake, & @@ -368,7 +369,8 @@ subroutine lsm_ruc_run & ! inputs integer, intent(in) :: me, master integer, intent(in) :: im, nlev, iter, lsoil_ruc, lsoil, kdt, isot, ivegsrc integer, intent(in) :: lsm_ruc, lsm - integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson + integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl real (kind=kind_phys), dimension(:), intent(in) :: & & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & @@ -752,7 +754,8 @@ subroutine lsm_ruc_run & ! inputs ! Set flag for mixed phase precipitation depending on microphysics scheme. ! For GFDL and Thompson, srflag is fraction of frozen precip for convective+explicit precip. - if (imp_physics==imp_physics_gfdl .or. imp_physics==imp_physics_thompson) then + if (imp_physics==imp_physics_gfdl .or. imp_physics==imp_physics_thompson .or. & + imp_physics == imp_physics_nssl) then frpcpn = .true. else frpcpn = .false. diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 5bee07cf6..75f63f3d2 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -612,6 +612,14 @@ dimensions = () type = integer intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F [do_mynnsfclay] standard_name = flag_for_mellor_yamada_nakanishi_niino_surface_layer_scheme long_name = flag to activate MYNN surface layer From 9d77cb1e5ebbf42864b9526d22a145ab585f0702 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 14 Oct 2021 22:19:05 -0500 Subject: [PATCH 048/217] Made IF test on tracer indices in post_run consistent with pre_run --- physics/GFS_DCNV_generic.F90 | 10 +++++++--- physics/GFS_DCNV_generic.meta | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 39 insertions(+), 3 deletions(-) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index fb807c3ca..a9e0ba7e0 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -114,7 +114,8 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & rainc, cldwrk, upd_mf, dwn_mf, det_mf, dtend, dtidx, index_of_process_dcnv, & index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv, gq0, save_q, & cnvw, cnvc, cnvw_phy_f3d, cnvc_phy_f3d, flag_for_dcnv_generic_tend, & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, ntrac,clw, & + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & + ntgnc, nthl, nthnc, nthv, ntgv, ntrac,clw, & satmedmf, trans_trac, errmsg, errflg) @@ -143,7 +144,8 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & real(kind=kind_phys), dimension(:,:,:), intent(inout) :: dtend integer, intent(in) :: dtidx(:,:), index_of_process_dcnv, index_of_temperature, & index_of_x_wind, index_of_y_wind, ntqv - integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc + integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & + ntgnc, nthl, nthnc, nthv, ntgv, ntrac real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw @@ -208,7 +210,9 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & + n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntgv ) then tracers = tracers + 1 idtend = dtidx(100+n,index_of_process_dcnv) if(idtend>0) then diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index 4703406c9..eb9bba6cf 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -716,6 +716,38 @@ dimensions = () type = integer intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in + optional = F [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers From 3e28640589f68fe75a2dd7fd0c828bb2aa053044 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 15 Oct 2021 20:00:26 -0500 Subject: [PATCH 049/217] Switched 'vertical_dimension' to 'vertical_layer_dimension' --- physics/mp_nssl.meta | 88 ++++++++++++++++++++++---------------------- 1 file changed, 44 insertions(+), 44 deletions(-) diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 772ba406b..dbfdfa506 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -150,7 +150,7 @@ standard_name = specific_humidity long_name = water vapor specific humidity units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -159,7 +159,7 @@ 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_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -168,7 +168,7 @@ standard_name = rain_mixing_ratio long_name = rain water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -177,7 +177,7 @@ 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_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -186,7 +186,7 @@ standard_name = snow_mixing_ratio long_name = snow water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -195,7 +195,7 @@ standard_name = graupel_mixing_ratio long_name = graupel mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -204,7 +204,7 @@ standard_name = hail_mixing_ratio long_name = moist (dry+vapor, no condensates) mixing ratio of hail units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -213,7 +213,7 @@ standard_name = cloud_condensation_nuclei_number_concentration long_name = number concentration of cloud condensation nuclei units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -222,7 +222,7 @@ standard_name = activated_cloud_condensation_nuclei_number_concentration long_name = number concentration of activated cloud condensation nuclei units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -231,7 +231,7 @@ 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_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -240,7 +240,7 @@ standard_name = mass_number_concentration_of_rain_water_in_air long_name = rain number concentration units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -249,7 +249,7 @@ standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air long_name = ice number concentration units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -258,7 +258,7 @@ standard_name = mass_number_concentration_of_snow_in_air long_name = snow number concentration units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -267,7 +267,7 @@ standard_name = mass_number_concentration_of_graupel_in_air long_name = graupel number concentration units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -276,7 +276,7 @@ standard_name = mass_number_concentration_of_hail_in_air long_name = hail number concentration units = kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -285,7 +285,7 @@ standard_name = graupel_volume long_name = graupel particle volume units = m3 kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -294,7 +294,7 @@ standard_name = hail_volume long_name = hail particle volume units = m3 kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -303,7 +303,7 @@ standard_name = air_temperature long_name = model layer mean temperature units = K - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -312,7 +312,7 @@ standard_name = dimensionless_exner_function long_name = dimensionless Exner function at model layer centers units = none - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -321,7 +321,7 @@ standard_name = air_pressure long_name = mean layer pressure units = Pa - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -377,7 +377,7 @@ standard_name = specific_humidity_of_new_state long_name = water vapor specific humidity units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -386,7 +386,7 @@ standard_name = cloud_liquid_water_mixing_ratio_of_new_state long_name = cloud water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -395,7 +395,7 @@ standard_name = rain_mixing_ratio_of_new_state long_name = rain water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -404,7 +404,7 @@ standard_name = cloud_ice_mixing_ratio_of_new_state long_name = ice water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -413,7 +413,7 @@ standard_name = snow_mixing_ratio_of_new_state long_name = snow water mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -422,7 +422,7 @@ standard_name = graupel_mixing_ratio_of_new_state long_name = graupel mixing ratio wrt dry+vapor (no condensates) units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -431,7 +431,7 @@ standard_name = hail_mixing_ratio_of_new_state long_name = moist (dry+vapor, no condensates) mixing ratio of hail updated by physics units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -440,7 +440,7 @@ standard_name = cloud_condensation_nuclei_number_concentration_of_new_state long_name = number concentration of cloud condensation nuclei updated by physics units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -449,7 +449,7 @@ standard_name = activated_cloud_condensation_nuclei_number_concentration_of_new_state long_name = number concentration of activated cloud condensation nuclei updated by physics units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -458,7 +458,7 @@ standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air_of_new_state long_name = cloud droplet number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -467,7 +467,7 @@ standard_name = mass_number_concentration_of_rain_of_new_state long_name = rain number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -476,7 +476,7 @@ standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air_of_new_state long_name = ice number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -485,7 +485,7 @@ standard_name = mass_number_concentration_of_snow_of_new_state long_name = snow number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -494,7 +494,7 @@ standard_name = mass_number_concentration_of_graupel_of_new_state long_name = graupel number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -503,7 +503,7 @@ standard_name = mass_number_concentration_of_hail_of_new_state long_name = hail number concentration units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -512,7 +512,7 @@ standard_name = graupel_volume_of_new_state long_name = graupel particle volume units = m3 kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -521,7 +521,7 @@ standard_name = hail_volume_of_new_state long_name = hail particle volume units = m3 kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -539,7 +539,7 @@ standard_name = dimensionless_exner_function long_name = dimensionless Exner function at model layer centers units = none - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -548,7 +548,7 @@ standard_name = air_pressure long_name = mean layer pressure units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -566,7 +566,7 @@ standard_name = lagrangian_tendency_of_air_pressure long_name = layer mean vertical velocity units = Pa s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -638,7 +638,7 @@ standard_name = radar_reflectivity_10cm long_name = instantaneous refl_10cm units = dBZ - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = out @@ -672,7 +672,7 @@ standard_name = effective_radius_of_stratiform_cloud_ice_particle long_name = eff. radius of cloud ice water particle in micrometer units = um - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -681,7 +681,7 @@ standard_name = effective_radius_of_stratiform_cloud_snow_particle long_name = effective radius of cloud snow particle in micrometer units = um - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -690,7 +690,7 @@ standard_name = effective_radius_of_stratiform_cloud_rain_particle long_name = effective radius of cloud rain particle in micrometers units = um - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout From a3a6c1b7e821587eb8eb46ff7d009b0482c4dd28 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 15 Oct 2021 20:37:28 -0500 Subject: [PATCH 050/217] Added convert_dry_rho flag --- physics/mp_nssl.F90 | 11 ++++++----- physics/mp_nssl.meta | 16 ++++++++++++++++ 2 files changed, 22 insertions(+), 5 deletions(-) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 2e90dfaab..754b99ca2 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -25,7 +25,7 @@ module mp_nssl !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & mpirank, mpiroot, & - imp_physics, imp_physics_nssl, & + imp_physics, imp_physics_nssl, convert_dry_rho, & nssl_cccn, nssl_alphah, nssl_alphahl, & nssl_ccn_on, nssl_hail_on, nssl_invertccn, first_time_step, & spechum, qc, qr, qi, qs, qh, qhl, & @@ -53,6 +53,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & logical, intent(in) :: first_time_step ! Hydrometeors + logical, intent(in ) :: convert_dry_rho real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) real(kind_phys), intent(inout) :: qc(1:ncol,1:nlev) real(kind_phys), intent(inout) :: qr(1:ncol,1:nlev) @@ -294,7 +295,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, & re_cloud, re_ice, re_snow, re_rain, & - imp_physics, & + imp_physics, convert_dry_rho, & imp_physics_nssl, nssl_ccn_on, & nssl_hail_on, nssl_invertccn, ntccn, ntccna, & errflg, errmsg) @@ -307,6 +308,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & real(kind_phys), intent(in ) :: con_rd integer, intent(in) :: mpirank ! Hydrometeors + logical, intent(in ) :: convert_dry_rho real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) real(kind_phys), intent(inout) :: cccn(:,:) ! (1:ncol,1:nlev) real(kind_phys), intent(inout) :: cccna(:,:) ! (1:ncol,1:nlev) @@ -426,7 +428,6 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & real, parameter :: dtpmax = 150. ! 300. ! 600. ! 120. real(kind_phys) :: dtptmp integer, parameter :: ndebug = 0 - logical, parameter :: convertdry = .true. logical :: invertccn real :: cwmas @@ -453,7 +454,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & !> - Convert specific humidity/moist mixing ratios to dry mixing ratios ! NOTE: Implied loops! qv_mp = spechum/(1.0_kind_phys-spechum) - IF ( convertdry ) THEN + IF ( convert_dry_rho ) THEN qc_mp = qc/(1.0_kind_phys-spechum) qr_mp = qr/(1.0_kind_phys-spechum) qi_mp = qi/(1.0_kind_phys-spechum) @@ -874,7 +875,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & !> - Convert dry mixing ratios to specific humidity/moist mixing ratios spechum = qv_mp/(1.0_kind_phys+qv_mp) - IF ( convertdry ) THEN + IF ( convert_dry_rho ) THEN qc = qc_mp/(1.0_kind_phys+qv_mp) qr = qr_mp/(1.0_kind_phys+qv_mp) qi = qi_mp/(1.0_kind_phys+qv_mp) diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index dbfdfa506..1ec3d03e4 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -79,6 +79,14 @@ type = integer intent = in optional = F +[convert_dry_rho] + standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air + long_name = flag for converting hydrometeors from moist to dry air + units = flag + dimensions = () + type = logical + intent = in + optional = F [imp_physics_nssl] standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme @@ -703,6 +711,14 @@ type = integer intent = in optional = F +[convert_dry_rho] + standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air + long_name = flag for converting hydrometeors from moist to dry air + units = flag + dimensions = () + type = logical + intent = in + optional = F [imp_physics_nssl] standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme From b2a5a9400a23cdcb3fc369f4eb51409890fab445 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Mon, 18 Oct 2021 23:01:12 -0500 Subject: [PATCH 051/217] Removed some commented code; pass in physical constants to init routine instead of using physcons module --- physics/GFS_rrtmg_pre.F90 | 102 +----------- physics/GFS_rrtmg_pre.meta | 2 +- physics/module_mp_nssl_2mom.F90 | 284 +++++++------------------------- physics/mp_nssl.F90 | 12 +- physics/mp_nssl.meta | 72 ++++++++ 5 files changed, 143 insertions(+), 329 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 99dc215b3..35ea44203 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -78,8 +78,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & make_DropletNumber, & make_RainNumber -! use module_mp_nssl_2mom, only: calc_eff_radius, calcnfromq, na - implicit none integer, intent(in) :: im, levs, lm, lmk, lmp, n_var_lndp, & @@ -685,10 +683,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo endif if_thompson if (imp_physics == imp_physics_nssl) then - ! write(6,*) 'rrtm_pre: set qx_mp for NSSL',ntlnc,ntinc,ntsnc,ntrnc IF ( .not. effr_in ) THEN do k=1,LMK -! IF ( me == mpiroot ) write(6,*) 'k,rho: ',k,rho(1,k) do i=1,IM qvs = qgrs(i,k,ntqv) qv_mp (i,k) = qvs/(1.-qvs) @@ -705,11 +701,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo ENDIF -! write(6,*) 'rrtmg_pre: max qctrac,qc,qcphy,nctrac,ccw,ccwphy: ',maxval(qc_mp),maxval(qc), & -! maxval(qc_phys),maxval(nc_mp),maxval(ccw),maxval(ccw_phys) -! write(6,*) 'rrtmg_pre: max ni,ns,nr = ',maxval(ni_mp),maxval(ns_mp),maxval(nr_mp) - ! IF ( maxval(ni_mp) > 1.0 ) write(6,*) 'NI max = ',maxval(ni_mp) - ! IF ( maxval(qi_mp) > 0.01e-3 ) write(6,*) 'QI max = ',maxval(qi_mp) endif endif do n=1,ncndl @@ -816,98 +807,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo else -#if 0 - ! calculate radii here, but something is not right with incoming number concentrations - ! IF ( .true. .and. first_time_step ) THEN - IF ( ( maxval(qc_mp) > 1.e-11 .and. maxval(nc_mp) < 1.e-5 ) .or. & - ( maxval(qr_mp) > 1.e-11 .and. maxval(nr_mp) < 1.e-5 ) .or. & - ( maxval(qi_mp) > 1.e-11 .and. maxval(ni_mp) < 1.e-5 ) .or. & - ( maxval(qs_mp) > 1.e-11 .and. maxval(ns_mp) < 1.e-5 ) .or. kdt < 3 ) THEN -! ( maxval(qs_mp) > 1.e-11 .and. maxval(ns_mp) < 1.e-5 ) .or. .true. ) THEN - - allocate( an(im,1,lm,na) ) - an(:,:,:,:) = 0.0 - IF ( .true. .or. kdt <= 3 ) THEN - IF ( me == mpiroot ) THEN -! write(6,*) 'before calcn: max ccw = ',maxval(nc_mp),sum(nc_mp) - nc_mp2 = nc_mp - max1 = maxval(nc_mp) - sum1 = sum(nc_mp) - ENDIF -! IF ( maxval(nc_mp) < 1.e-20 ) THEN - call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & - & qcw=qc_mp,qci=qi_mp, qsw=qs_mp,qrw=qr_mp, & - & ccw=nc_mp,cci=ni_mp, csw=ns_mp,crw=nr_mp, & - & qv=qv_mp, invertccn_flag=nssl_invertccn ) -! ENDIF - IF ( .false. .and. me == mpiroot ) THEN - max2 = maxval(nc_mp) - sum2 = sum(nc_mp) - write(6,*) 'after calcn: max ccw = ',maxval(nc_mp),sum(nc_mp) - IF ( Abs(max1-max2) < 1.0 .and. Abs(sum2-sum1) > 1.0 ) THEN - DO k=1,lm - DO i=1,im - IF ( qc_mp(i,k) > 1.e-6 .and. (nc_mp2(i,k) /= nc_mp(i,k) ) ) THEN - write(6,*) 'i,k,qc,nc1,nc2 = ',i,k,qc_mp(i,k),nc_mp2(i,k),nc_mp(i,k) - ENDIF - ENDDO - ENDDO - ENDIF - ENDIF - ELSE -! call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & -! & qcw=qc_mp, & !qci=qi_mp, & ! qsw=qs_mp,qrw=qr_mp, & -! & ccw=nc_mp, & !cci=ni_mp, & ! csw=ns_mp,crw=nr_mp, & -! & cccn=cccn_mp,qv=qv_mp ) - call calcnfromq(nx=im,ny=1,nz=lm,an=an,na=na,nor=0,norz=0,dn=rho, & - & qci=qi_mp, qsw=qs_mp,qrw=qr_mp, & - & cci=ni_mp, csw=ns_mp,crw=nr_mp, & - & qv=qv_mp, invertccn_flag=nssl_invertccn ) - ENDIF - ! write(0,*) 'rrtmg_pre2: ni,ns,nr maxval: ',maxval(ni_mp),maxval(ns_mp),maxval(nr_mp),kdt - - deallocate( an ) - ENDIF - re_cloud = 0 - re_ice = 0 - re_snow = 0 - re_rain = 0 - call calc_eff_radius & - & (nx=im,ny=1,nz=lm,na=1,jyslab=1 & - & ,nor=0,norz=0 & - & ,t1=re_cloud,t2=re_ice,t3=re_snow,t4=re_rain & - & ,qcw=qc_mp,qci=qi_mp,qsw=qs_mp,qrw=qr_mp & - & ,ccw=nc_mp,cci=ni_mp,csw=ns_mp,crw=nr_mp & - & ,dn=rho ) - - do k=1,lm - k1 = k + kd - do i=1,im - IF ( .false. ) THEN - effrl(i,k1) = MAX(2.51E-6, MIN( re_cloud(i,k), 50.E-6))*1.e6 - effri(i,k1) = MAX(10.01E-6, MIN( re_ice(i,k), 125.E-6))*1.e6 - effrs(i,k1) = MAX(25.E-6, MIN( re_snow(i,k), 999.E-6))*1.e6 - ! effri(i,k1) = effri_inout(i,k)! re_ice (i,k) - ! effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) - ELSE - effrl(i,k1) = effrl_inout(i,k)! re_cloud (i,k) - effri(i,k1) = effri_inout(i,k)! re_ice (i,k) - effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) - ENDIF - effrr(i,k1) = MAX(25.E-6, MIN( re_rain(i,k), 2999.E-6))*1.e6 - enddo - enddo - - ! Update global arrays - do k=1,lm - k1 = k + kd - do i=1,im - effrl_inout(i,k) = effrl(i,k1) - effri_inout(i,k) = effri(i,k1) - effrs_inout(i,k) = effrs(i,k1) - enddo - enddo -#endif + ! not used yet -- effr_in should always be true for now endif elseif (imp_physics == imp_physics_thompson) then ! Thompson MP diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index f0f178187..3f1068229 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1,7 +1,7 @@ [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,module_mp_nssl_2mom.F90 + 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,physcons.F90,physparam.f,radcons.f90,radiation_aerosols.f dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90,radiation_cloud_overlap.F90 diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 65fecae7e..c96ab4861 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1,7 +1,8 @@ -!WRF:MODEL_LAYER:PHYSICS +! !> \file module_mp_nssl_2mom.F90 +!! This file contains the NSSL cloud microphysics scheme by Edward Mansell (NOAA/NSSL) -! prepocessed on "Oct 6 2021" at "17:14:05" +! prepocessed on "Oct 18 2021" at "17:18:18" @@ -169,11 +170,11 @@ MODULE module_mp_nssl_2mom - use physcons, only: con_pi, con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps IMPLICIT NONE public nssl_2mom_driver public nssl_2mom_init + public nssl_2mom_init_const public calc_eff_radius public calcnfromq private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis @@ -830,13 +831,13 @@ MODULE module_mp_nssl_2mom ! new values for cs and ds real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient - real, parameter :: cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv - real, parameter :: pi = con_pi + real :: cp608 = 0.608 ! constant used in conversion of T to Tv + real :: gr = 9.8 + + real, parameter :: pi = 3.141592653589793 real, parameter :: piinv = 1./pi real, parameter :: pid4 = pi/4.0 - real, parameter :: gr = con_g - ! ! max and min mean volumes ! @@ -899,19 +900,23 @@ MODULE module_mp_nssl_2mom real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation real, parameter :: cawbolton = 17.67 - real, parameter :: tfr = con_t0c, tfrh = 233.15 + real, parameter :: tfrh = 233.15 + real :: tfr = 273.15 - real, parameter :: cp = con_cp, rd = con_rd, rw = con_rv - REAL, PRIVATE, parameter :: cpl = con_cliq ! 4190.0 - REAL, PRIVATE, parameter :: cpigb = con_csol ! 2106.0 - real, parameter :: cpi = 1./cp - real, parameter :: cap = rd/cp, poo = 1.0e+05 + real :: cp = 1004.0, rd = 287.04 + real :: rw = 461.5 ! gas const. for water vapor + REAL, PRIVATE :: cpl = 4190.0 + REAL, PRIVATE :: cpigb = 2106.0 + real :: cpi + real :: cap + real :: tfrcbw + real :: tfrcbi + real :: rovcp + real, parameter :: poo = 1.0e+05 real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity - real, parameter :: tfrcbw = tfr - cbw - real, parameter :: tfrcbi = tfr - cbi ! GHB: Needed for eqtset=2 in cm1 ! REAL, PRIVATE :: cv = cp - rd @@ -1094,44 +1099,6 @@ MODULE module_mp_nssl_2mom ! ##################################################################### ! ##################################################################### - SUBROUTINE wrf_debug( level, message ) - implicit none - integer :: level - character(*) :: message - - IF ( level < 0 ) THEN - write(0,*) message - ENDIF - - END SUBROUTINE wrf_debug - -! -! ##################################################################### -! - SUBROUTINE wrf_message( message ) - implicit none - character(*) :: message - - write(0,*) message - - END SUBROUTINE wrf_message - -! -! ##################################################################### -! - SUBROUTINE wrf_error_fatal( message ) - ! USE COMMASMPI_MODULE, only: commasmpi_abort - implicit none - character(*) :: message - - write(0,*) message - ! call commasmpi_abort() - - END SUBROUTINE wrf_error_fatal - -! -! ##################################################################### -! REAL FUNCTION fqvs(t) implicit none @@ -1148,6 +1115,35 @@ END FUNCTION fqis +! ##################################################################### +! ##################################################################### + + + SUBROUTINE nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + implicit none + real, intent(in) :: con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps + + cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv + gr = con_g + tfr = con_t0c + cp = con_cp + rd = con_rd + rw = con_rv + cpl = con_cliq ! 4190.0 + cpigb = con_csol ! 2106.0 + cpi = 1./cp + cap = rd/cp + tfrcbw = tfr - cbw + tfrcbi = tfr - cbi + rovcp = rd/cp + + + + RETURN + END SUBROUTINE nssl_2mom_init_const ! ##################################################################### ! ##################################################################### @@ -1581,7 +1577,9 @@ SUBROUTINE nssl_2mom_init( & ! ltmp = lhlw ENDIF ELSE - CALL wrf_error_fatal( 'nssl_2mom_init: Invalid value of ipctmp' ) + errmsg = 'nssl_2mom_init: Invalid value of ipctmp' + errflg = 1 + RETURN ENDIF @@ -2299,19 +2297,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw - IF ( switchccn .and. lccna > 1 .and. .not. invertccn) THEN - ! hack to switch from ccn to ccna from a restart - - DO jy = jts,jte - DO kz = kts,kte - DO ix = its,ite - cn(ix,kz,jy) = Max( 0.0, old_qccn - cn(ix,kz,jy) ) - ENDDO - ENDDO - ENDDO - - switchccn = .false. - ENDIF ! ENDIF ! itimestep == 1 @@ -2365,6 +2350,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) ancuten(its:ite,1,kts:kte,:) = 0.0 + thproclocal(:,:) = 0.0 DO jy = jts,jye @@ -2739,7 +2725,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,t0,t9 & & ,an,dn1,t77 & & ,pn,wn & - & ,thproclocal,nproc,dx1,dy1,dz2d & & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) @@ -2823,7 +2808,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw DO kz = kts,kte DO ix = its,ite re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6)) - re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 125.E-6)) + re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 200.E-6)) re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation) IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) @@ -2925,6 +2910,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO ! jy + @@ -2957,7 +2943,6 @@ REAL FUNCTION GAMMA_SP(xx) IF ( xx <= 0.0 ) THEN write(0,*) 'Argument to gamma must be > 0!! xx = ',xx - STOP ENDIF x = xx @@ -3021,7 +3006,6 @@ real function GAMXINF(A1,X1) XAM=-X+A*DLOG(X) IF (XAM.GT.700.0.OR.A.GT.170.0) THEN WRITE(*,*)'a and/or x too large' - STOP ENDIF IF (X.EQ.0.0) THEN GIN=0.0 @@ -3082,7 +3066,6 @@ double precision function GAMXINFDP(A1,X1) XAM=-X+A*DLOG(X) IF (XAM.GT.700.0.OR.A.GT.170.0) THEN WRITE(*,*)'a and/or x too large' - STOP ENDIF IF (X.EQ.0.0) THEN GIN=0.0 @@ -3502,7 +3485,6 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) del = tmp - dgam*i IF ( i+1 > ngm0 ) THEN write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp - STOP ENDIF g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami ! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua) @@ -3790,8 +3772,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO n = 1,ndfall - IF ( ( il /= lc .and. il /= li ) .and. do_accurate_sedimentation .and. n .ge. 2 .and. & - ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN + IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN ! ! zero the precip flux arrays (2d) ! @@ -3799,7 +3780,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! xvt(:,:,:,il) = 0.0 dummy = 0.d0 - IF ( il == lh .or. il == lr ) xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin + xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & & xvt, rhovtzx, & @@ -6403,9 +6384,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! DO il = lc,lhab ! IF ( il .ne. lr ) THEN DO mgs = 1,ngscnt - IF ( ildo == 0 .or. ildo == lc ) THEN - vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) - ENDIF + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) IF ( li .gt. 1 ) THEN ! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) ! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) @@ -8128,8 +8107,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & write(0,*) 'dtmpr = ',dtmpr write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN - write(0,*) 'dbz out of bounds! STOP!' -! STOP + write(0,*) 'dbz out of bounds!' ENDIF ENDIF @@ -8178,7 +8156,6 @@ SUBROUTINE NUCOND & & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & - & ,thproc,numproc, dx1,dy1,gz & & ,axtra,io_flag & & ,ssfilt,t00,t77,flag_qndrop & & ) @@ -8233,9 +8210,6 @@ SUBROUTINE NUCOND & ! local - integer, intent(in) :: numproc - real, intent(inout) :: thproc(nz,numproc) - real, intent(in) :: dx1,dy1, gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) logical :: io_flag @@ -8397,7 +8371,6 @@ SUBROUTINE NUCOND & real :: cvm,cpm,rmm - real, parameter :: rovcp = rd/cp real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure integer :: kstag @@ -8854,11 +8827,6 @@ SUBROUTINE NUCOND & IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) - qx(mgs,lc)*rho0(mgs)*dv/dtp ! evaporation rate - ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp ENDIF @@ -8915,11 +8883,6 @@ SUBROUTINE NUCOND & cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) - felv(mgs)*QEVAP/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) - QEVAP*rho0(mgs)*dv/dtp ! evaporation rate - ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp ENDIF @@ -9190,11 +9153,6 @@ SUBROUTINE NUCOND & IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) ENDIF - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + e1*(DCLOUD + dqr)*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + (DCLOUD + dqr)*rho0(mgs)*dv/dtp ! condensation rate - ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp @@ -9262,11 +9220,6 @@ SUBROUTINE NUCOND & thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate - ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp ENDIF @@ -9524,11 +9477,6 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate - ENDIF ENDIF ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air @@ -9635,11 +9583,6 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate - ENDIF ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) ENDIF @@ -9698,11 +9641,6 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*DCLOUD/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + DCLOUD*rho0(mgs)*dv/dtp ! condensation rate - ENDIF ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ENDIF @@ -9750,11 +9688,6 @@ SUBROUTINE NUCOND & IF ( qvex .gt. 0.0 ) THEN thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) - IF ( numproc > 1 ) THEN - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - thproc(kzbeg-1+kgs(mgs),16) = thproc(kzbeg-1+kgs(mgs),16) + felv(mgs)*qvex/(CP*pi0(mgs))*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),17) = thproc(kzbeg-1+kgs(mgs),17) + qvex*rho0(mgs)*dv/dtp ! condensation rate - ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp ENDIF @@ -10775,7 +10708,6 @@ subroutine nssl_2mom_gs & real cvm,cpm,rmm - real, parameter :: rovcp = rd/cp real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure ! real fcci(ngs), fcip(ngs) @@ -19731,104 +19663,6 @@ subroutine nssl_2mom_gs & ! ! Load the save arrays ! - IF ( numproc > 1 ) THEN - DO mgs = 1,ngscnt - dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) - IF ( ipconc > 2 ) THEN - thproc(kzbeg-1+kgs(mgs),1) = thproc(kzbeg-1+kgs(mgs),1) + crfrzf(mgs)*dtp*dv - ELSE - thproc(kzbeg-1+kgs(mgs),1) = thproc(kzbeg-1+kgs(mgs),1) + qrfrzf(mgs)*rho0(mgs)*dtp*dv - ENDIF - thproc(kzbeg-1+kgs(mgs),2) = thproc(kzbeg-1+kgs(mgs),2) + il5(mgs)*ciacrf(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),3) = thproc(kzbeg-1+kgs(mgs),3) + chcnsh(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),4) = thproc(kzbeg-1+kgs(mgs),4) + chcnih(mgs)*dtp*dv - IF ( qhacw(mgs)+qhacr(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN - thproc(kzbeg-1+kgs(mgs),5) = thproc(kzbeg-1+kgs(mgs),5) + (qhacw(mgs)+qhacr(mgs)+qhshr(mgs))*rho0(mgs)*dtp*dv - ENDIF - thproc(kzbeg-1+kgs(mgs),6) = thproc(kzbeg-1+kgs(mgs),6) + qracw(mgs)*rho0(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),7) = thproc(kzbeg-1+kgs(mgs),7) + qrcnw(mgs)*rho0(mgs)*dtp*dv - IF ( qhacw(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN - thproc(kzbeg-1+kgs(mgs),8) = thproc(kzbeg-1+kgs(mgs),8) + (vhacw(mgs)+vhacr(mgs)+vhshdr(mgs))*dtp*dv -! thproc(kzbeg-1+kgs(mgs),8) = thproc(kzbeg-1+kgs(mgs),8) + qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh)*dtp*dv - ENDIF - thproc(kzbeg-1+kgs(mgs),9) = thproc(kzbeg-1+kgs(mgs),9) + ptem(mgs)*dtp*dv ! latent heating - thproc(kzbeg-1+kgs(mgs),10) = thproc(kzbeg-1+kgs(mgs),10) + & - & ( chmul1(mgs) + chlmul1(mgs) )*dtp*dv - IF ( lf > 1 ) THEN - ELSE - thproc(kzbeg-1+kgs(mgs),11) = thproc(kzbeg-1+kgs(mgs),11) + & - & ( csplinter(mgs) + csplinter2(mgs) )*dtp*dv - ENDIF - thproc(kzbeg-1+kgs(mgs),12) = thproc(kzbeg-1+kgs(mgs),12) + qrfrzf(mgs)*rho0(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),13) = thproc(kzbeg-1+kgs(mgs),13) + il5(mgs)*qiacrf(mgs)*rho0(mgs)*dtp*dv ! mass of rain freezing by ice crystal capture - thproc(kzbeg-1+kgs(mgs),14) = thproc(kzbeg-1+kgs(mgs),14) + crcnw(mgs)*dtp*dv ! rain drop prod. by autoconv. - thproc(kzbeg-1+kgs(mgs),15) = thproc(kzbeg-1+kgs(mgs),15) + (pcrwi(mgs)-crcnw(mgs))*dtp*dv ! rain drop prod by melting/shedding (i.e., everything but autoconv.) -! thproc(kzbeg-1+kgs(mgs),18) = thproc(kzbeg-1+kgs(mgs),18) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate - thproc(kzbeg-1+kgs(mgs),19) = thproc(kzbeg-1+kgs(mgs),19) + pmlt(mgs)*rho0(mgs)*dv ! melting rate - thproc(kzbeg-1+kgs(mgs),20) = thproc(kzbeg-1+kgs(mgs),20) + pdep(mgs)*rho0(mgs)*dv ! deposition rate - thproc(kzbeg-1+kgs(mgs),21) = thproc(kzbeg-1+kgs(mgs),21) + (psub(mgs)-pdep(mgs))*rho0(mgs)*dv ! sublimation rate - thproc(kzbeg-1+kgs(mgs),22) = thproc(kzbeg-1+kgs(mgs),22) + (pfrz(mgs)-pmlt(mgs))*rho0(mgs)*dv ! freezing rate - -! thproc(kzbeg-1+kgs(mgs),20) = thproc(kzbeg-1+kgs(mgs),20) + (1./pi0(mgs))*felfcp(mgs)*pvap(mgs)*rho0(mgs)*dv ! deposition rate -! thproc(kzbeg-1+kgs(mgs),21) = thproc(kzbeg-1+kgs(mgs),21) + (1./pi0(mgs))*felscp(mgs)*psub(mgs)*rho0(mgs)*dv ! sublimation rate -! thproc(kzbeg-1+kgs(mgs),22) = thproc(kzbeg-1+kgs(mgs),22) + (1./pi0(mgs))*felfcp(mgs)*pfrz(mgs)*rho0(mgs)*dv ! (pfrz(mgs)-pmlt(mgs))*rho0(mgs)*dv ! freezing rate - - thproc(kzbeg-1+kgs(mgs),23) = thproc(kzbeg-1+kgs(mgs),23) + crfrzs(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),24) = thproc(kzbeg-1+kgs(mgs),24) + il5(mgs)*ciacrs(mgs)*dtp*dv - - thproc(kzbeg-1+kgs(mgs),25) = thproc(kzbeg-1+kgs(mgs),25) + qhmlr(mgs)*rho0(mgs)*dv ! melting rate - thproc(kzbeg-1+kgs(mgs),26) = thproc(kzbeg-1+kgs(mgs),26) + qhlmlr(mgs)*rho0(mgs)*dv ! melting rate - - IF ( qhlacw(mgs)+qhlacr(mgs) > 0.0 .and. temg(mgs) < tfr ) THEN - thproc(kzbeg-1+kgs(mgs),27) = thproc(kzbeg-1+kgs(mgs),27) + (qhlacw(mgs)+qhlacr(mgs)+qhlshr(mgs))*rho0(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),28) = thproc(kzbeg-1+kgs(mgs),28) + (qhlacw(mgs))*rho0(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),29) = thproc(kzbeg-1+kgs(mgs),29) + (qhlacr(mgs))*rho0(mgs)*dtp*dv - ENDIF - - IF ( temg(mgs) < tfr ) THEN - thproc(kzbeg-1+kgs(mgs),30) = thproc(kzbeg-1+kgs(mgs),30) + (qhacw(mgs))*rho0(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),31) = thproc(kzbeg-1+kgs(mgs),31) + (qhacr(mgs))*rho0(mgs)*dtp*dv - ENDIF - - thproc(kzbeg-1+kgs(mgs),32) = thproc(kzbeg-1+kgs(mgs),32) + qhlcnh(mgs)*rho0(mgs)*dtp*dv ! graupel mass conversion to hail - - IF ( ihrn > 0 ) THEN - thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + ciihr(mgs)*dtp*dv ! contact freezing of droplets - ELSE - IF ( qwctfz(mgs)*dtp >= qxmin(li) ) THEN - thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + cwctfz(mgs)*dtp*dv ! contact freezing of droplets - ENDIF - ENDIF - thproc(kzbeg-1+kgs(mgs),34) = thproc(kzbeg-1+kgs(mgs),34) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate - IF ( qiint(mgs)*dtp >= qxmin(li) ) THEN - thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + ciint(mgs)*dtp*dv ! primary ice initiation - ENDIF - IF ( lf > 1 ) THEN - ELSE - thproc(kzbeg-1+kgs(mgs),38) = thproc(kzbeg-1+kgs(mgs),38) + (vhacw(mgs)+vhacr(mgs)+vhshdr(mgs))*dtp*dv - ENDIF - IF ( lhl > 1 ) THEN - thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + chlcnhhl(mgs)*dtp*dv - thproc(kzbeg-1+kgs(mgs),37) = thproc(kzbeg-1+kgs(mgs),37) + (vhlacw(mgs)+vhlacr(mgs)+vhlshdr(mgs))*dtp*dv - ELSE - IF ( lf > 1 ) THEN - ELSE - thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + (pchwi(mgs))*dtp*dv - thproc(kzbeg-1+kgs(mgs),39) = thproc(kzbeg-1+kgs(mgs),39) + (pchwd(mgs))*dtp*dv - thproc(kzbeg-1+kgs(mgs),37) = thproc(kzbeg-1+kgs(mgs),37) + (chmlr(mgs))*dtp*dv - ENDIF - ENDIF -! thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate - - -! ptem(mgs) = & -! & (1./pi0(mgs))* & -! & (felfcp(mgs)*pfrz(mgs) & -! & +felscp(mgs)*psub(mgs) & -! & +felvcp(mgs)*pvap(mgs)) - - ENDDO - ENDIF ! Sample code for using the axtra array to load microphysical rates or quantities for output diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 754b99ca2..e607e132d 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -25,6 +25,8 @@ module mp_nssl !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & mpirank, mpiroot, & + con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps, & imp_physics, imp_physics_nssl, convert_dry_rho, & nssl_cccn, nssl_alphah, nssl_alphahl, & nssl_ccn_on, nssl_hail_on, nssl_invertccn, first_time_step, & @@ -32,8 +34,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl ) - use module_mp_nssl_2mom, only: nssl_2mom_init, calcnfromq, na - use physcons, only: con_rd + use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const, calcnfromq, na implicit none @@ -43,6 +44,8 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent( out) :: errflg integer, intent(in) :: threads logical, intent(in) :: restart + real(kind_phys), intent(in) :: con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps integer, intent(in) :: mpirank integer, intent(in) :: mpiroot @@ -134,6 +137,11 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & return end if + ! set physical constants + call nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + ! Set internal dimensions ims = 1 ime = ncol diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 1ec3d03e4..4d3f3b00f 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -71,6 +71,78 @@ type = integer intent = in optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[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 + optional = F +[con_cliq] + standard_name = specific_heat_of_liquid_water_at_constant_pressure + long_name = specific heat of liquid water at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_csol] + standard_name = specific_heat_of_ice_at_constant_pressure + long_name = specific heat of ice at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme From 383cb3c778eccf1fcb14c7121fb0450df280d120 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Tue, 9 Nov 2021 21:49:55 -0600 Subject: [PATCH 052/217] Cleaned up unused code and variables. --- physics/GFS_rrtmg_pre.F90 | 36 +---- physics/GFS_rrtmg_pre.meta | 14 -- physics/GFS_suite_interstitial.F90 | 10 +- physics/GFS_suite_interstitial.meta | 16 -- physics/module_mp_nssl_2mom.F90 | 30 ++-- physics/mp_nssl.F90 | 198 +++-------------------- physics/mp_nssl.meta | 237 +++++----------------------- 7 files changed, 88 insertions(+), 453 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 35ea44203..7396c676d 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -19,7 +19,7 @@ end subroutine GFS_rrtmg_pre_init subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & - ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, first_time_step, & + ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & imp_physics,imp_physics_nssl, nssl_ccn_on, nssl_invertccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & @@ -36,7 +36,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & gasvmr_o2, gasvmr_co, gasvmr_cfc11, gasvmr_cfc12, gasvmr_cfc22, & gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, faersw1, faersw2, faersw3, faerlw1, faerlw2, & - faerlw3, alpha, errmsg, errflg,mpiroot) + faerlw3, alpha, errmsg, errflg) use machine, only: kind_phys @@ -103,7 +103,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & logical, intent(in) :: lsswr, lslwr, ltaerosol, lgfdlmprad, & uni_cld, effr_in, do_mynnedmf, & - lmfshal, lmfdeep2, pert_clds,first_time_step + lmfshal, lmfdeep2, pert_clds logical, intent(in) :: nssl_ccn_on, nssl_invertccn real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp @@ -176,7 +176,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - integer, intent(in) :: mpiroot ! Local variables integer :: ncndl @@ -197,10 +196,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(im,lm+LTP) :: & re_cloud, re_ice, re_snow, qv_mp, qc_mp, & qi_mp, qs_mp, nc_mp, ni_mp, nwfa - ! for NSSL MP - real(kind=kind_phys), dimension(im,lm+LTP) :: & - re_rain, qr_mp, ns_mp, nr_mp, nh_mp, vh_mp, cccn_mp,cccna_mp, nc_mp2 - real, allocatable :: an(:,:,:,:) ! temporary scalar array ! for F-A MP real(kind=kind_phys), dimension(im,lm+LTP) :: qc_save, qi_save, qs_save @@ -223,7 +218,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & its, ite, jts, jte, kts, kte real(kind=kind_phys) :: qvs - real (kind=kind_phys) :: sum1,sum2,max1,max2 ! !===> ... begin here ! @@ -682,26 +676,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo endif if_thompson - if (imp_physics == imp_physics_nssl) then - IF ( .not. effr_in ) THEN - do k=1,LMK - do i=1,IM - qvs = qgrs(i,k,ntqv) - qv_mp (i,k) = qvs/(1.-qvs) - rho (i,k) = con_eps*plyr(i,k)*100./(con_rd*tlyr(i,k)*(qv_mp(i,k)+con_eps)) - qc_mp (i,k) = tracer1(i,k,ntcw)/(1.-qvs) - qi_mp (i,k) = tracer1(i,k,ntiw)/(1.-qvs) - qs_mp (i,k) = tracer1(i,k,ntsw)/(1.-qvs) - qr_mp (i,k) = tracer1(i,k,ntrw)/(1.-qvs) - nc_mp (i,k) = tracer1(i,k,ntlnc)/(1.-qvs) - ni_mp (i,k) = tracer1(i,k,ntinc)/(1.-qvs) - ns_mp (i,k) = tracer1(i,k,ntsnc)/(1.-qvs) - nr_mp (i,k) = tracer1(i,k,ntrnc)/(1.-qvs) - IF ( nssl_ccn_on ) cccn_mp(i,k) = tracer1(i,k,ntccn)/(1.-qvs) - enddo - enddo - ENDIF - endif endif do n=1,ncndl do k=1,LMK @@ -1097,7 +1071,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif ! MYNN PBL or GF - elseif(imp_physics == imp_physics_thompson ) then ! Thompson MP + elseif(imp_physics == imp_physics_thompson) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv !-- MYNN PBL or convective GF @@ -1196,4 +1170,6 @@ end subroutine GFS_rrtmg_pre_run subroutine GFS_rrtmg_pre_finalize () end subroutine GFS_rrtmg_pre_finalize +!! @} + end module GFS_rrtmg_pre diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 3f1068229..c14fe77af 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -267,13 +267,6 @@ dimensions = () type = integer intent = in -[first_time_step] - standard_name = flag_for_first_timestep - long_name = flag for first time step for time integration loop (cold/warmstart) - units = flag - dimensions = () - type = logical - intent = in optional = F [imp_physics] standard_name = control_for_microphysics_scheme @@ -1129,11 +1122,4 @@ dimensions = () type = integer intent = out -[mpiroot] - standard_name = mpi_root - long_name = master MPI-rank - units = index - dimensions = () - type = integer - intent = in optional = F diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 7bd9ea010..52bc65c2c 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -512,7 +512,7 @@ end subroutine GFS_suite_interstitial_3_finalize !> \section arg_table_GFS_suite_interstitial_3_run Argument Table !! \htmlinclude GFS_suite_interstitial_3_run.html !! - subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & + subroutine GFS_suite_interstitial_3_run (otsptflag, & im, levs, nn, cscnv, & satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & @@ -531,8 +531,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, ntracp1, & implicit none ! interface variables - logical, intent(in) :: otsptflag(1:ntracp1)! on/off switch for tracer transport - integer, intent(in) :: ntracp1 + logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport (size ntrac) integer, intent(in ) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, ntsw,& ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & @@ -717,7 +716,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr imp_physics_nssl, nssl_invertccn, nssl_ccn_on, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & - qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, ntracp1, errmsg, errflg) + qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, errmsg, errflg) use machine, only: kind_phys use module_mp_nssl_2mom, only: qccn @@ -728,8 +727,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ! interface variables - logical, intent(in) :: otsptflag(1:ntracp1)! on/off switch for tracer transport by updraft and - integer, intent(in) :: ntracp1 + logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport by updraft and integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index dc9044243..251ca49f9 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1048,14 +1048,6 @@ type = logical intent = in optional = F -[ntracp1] - standard_name = number_of_tracers_plus_one - long_name = number of tracers plus one - units = count - dimensions = () - type = integer - intent = in - optional = F [im] standard_name = horizontal_loop_extent long_name = horizontal loop extent @@ -1872,14 +1864,6 @@ type = logical intent = in optional = F -[ntracp1] - standard_name = number_of_tracers_plus_one - long_name = number of tracers plus one - units = count - dimensions = () - type = integer - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index c96ab4861..7131739c0 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1,8 +1,4 @@ ! !> \file module_mp_nssl_2mom.F90 -!! This file contains the NSSL cloud microphysics scheme by Edward Mansell (NOAA/NSSL) - - -! prepocessed on "Oct 18 2021" at "17:18:18" @@ -11,6 +7,9 @@ +!--------------------------------------------------------------------- +! code snapshot: "Oct 29 2021" at "19:44:39" +!--------------------------------------------------------------------- !--------------------------------------------------------------------- ! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: ! moist_adv_opt = 4, @@ -2811,7 +2810,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 200.E-6)) re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation) - IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) + IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 200.E-6)) ENDDO ENDDO @@ -3777,7 +3776,6 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! zero the precip flux arrays (2d) ! -! xvt(:,:,:,il) = 0.0 dummy = 0.d0 xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin @@ -6384,7 +6382,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! DO il = lc,lhab ! IF ( il .ne. lr ) THEN DO mgs = 1,ngscnt - vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + IF ( ildo == 0 .or. ildo == lc ) THEN + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + ENDIF IF ( li .gt. 1 ) THEN ! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) ! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) @@ -10867,6 +10867,7 @@ subroutine nssl_2mom_gs & real chlsbv(ngs), chldpv(ngs) real chlmlr(ngs), chlmlrr(ngs) + real chlfmlr(ngs) ! real chlmlrsave(ngs),chlsave(ngs),qhlsave(ngs) real chlshr(ngs), chlshrr(ngs) @@ -12017,6 +12018,13 @@ subroutine nssl_2mom_gs & ENDIF +! +! Set liquid water fraction +! + fhw(:) = 0.0 + fsw(:) = 0.0 + fhlw(:) = 0.0 + @@ -15547,6 +15555,7 @@ subroutine nssl_2mom_gs & chmlr(:) = 0.0 chmlrr(:) = 0.0 chlmlr(:) = 0.0 + chlfmlr(:) = 0.0 ! chlmlrsave(:) = 0.0 ! qhlmlrsave(:) = 0.0 ! chlsave(:) = 0.0 @@ -18147,10 +18156,8 @@ subroutine nssl_2mom_gs & ! qwfrzp(mgs) = frac*qwfrzp(mgs) ! qwctfzp(mgs) = frac*qwctfzp(mgs) qwfrzc(mgs) = frac*qwfrzc(mgs) - qwfrzis(mgs) = frac*qwfrzis(mgs) qwfrz(mgs) = frac*qwfrz(mgs) qwctfzc(mgs) = frac*qwctfzc(mgs) - qwctfzis(mgs) = frac*qwctfzis(mgs) qwctfz(mgs) = frac*qwctfz(mgs) qracw(mgs) = frac*qracw(mgs) qsacw(mgs) = frac*qsacw(mgs) @@ -18818,10 +18825,9 @@ subroutine nssl_2mom_gs & write(iunit,*) ' Conc:' write(iunit,*) pccii(mgs),pccid(mgs) write(iunit,*) il5(mgs),cicint(mgs) - write(iunit,*) cwacii(mgs),cwfrzc(mgs),cwctfzc(mgs) + write(iunit,*) cwfrzc(mgs),cwctfzc(mgs) write(iunit,*) cicichr(mgs) write(iunit,*) chmul1(mgs) - write(iunit,*) cfmul1(mgs) write(iunit,*) chlmul1(mgs) write(iunit,*) csmul(mgs) ! @@ -18835,7 +18841,6 @@ subroutine nssl_2mom_gs & write(iunit,*) -il5(mgs)*qiacw(mgs) write(iunit,*) -il5(mgs)*qwfrzc(mgs) write(iunit,*) -il5(mgs)*qwctfzc(mgs) - write(iunit,*) -il5(mgs)*qwctfzis(mgs) ! write(iunit,*) -il5(mgs)*qwfrzp(mgs) ! write(iunit,*) -il5(mgs)*qwctfzp(mgs) write(iunit,*) -il5(mgs)*qiihr(mgs) @@ -18884,7 +18889,6 @@ subroutine nssl_2mom_gs & write(iunit,*) -qhlacr(mgs) write(iunit,*) qrcev(mgs) write(iunit,*) 'pqrwd = ', pqrwd(mgs) - write(iunit,*) 'fhw, fhlw = ',fhw(mgs),fhlw(mgs) write(iunit,*) 'qrzfac = ', qrzfac(mgs) ! diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index e607e132d..cf1a4b8fa 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -27,14 +27,12 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & mpirank, mpiroot, & con_g, con_rd, con_cp, con_rv, & con_t0c, con_cliq, con_csol, con_eps, & - imp_physics, imp_physics_nssl, convert_dry_rho, & + imp_physics, imp_physics_nssl, & nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_ccn_on, nssl_hail_on, nssl_invertccn, first_time_step, & - spechum, qc, qr, qi, qs, qh, qhl, & - cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl ) + nssl_ccn_on, nssl_hail_on, nssl_invertccn ) - use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const, calcnfromq, na + use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const implicit none @@ -53,57 +51,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent(in) :: imp_physics_nssl real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn - logical, intent(in) :: first_time_step - ! Hydrometeors - logical, intent(in ) :: convert_dry_rho - real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) - 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) :: qhl(:,:) ! (1:ncol,1:nlev) ! hail - real(kind_phys), intent(inout) :: cccn(:,:) ! (1:ncol,1:nlev) - real(kind_phys), intent(inout) :: cccna(:,:) ! (1:ncol,1:nlev) ! currently not used - 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) :: chl(:,:) ! (1:ncol,1:nlev) ! hail number - real(kind_phys), intent(inout) :: vh(1:ncol,1:nlev) ! graupel volume - real(kind_phys), intent(inout) :: vhl(:,:) ! (1:ncol,1:nlev) ! hail volume - - ! State variables and timestep information - real(kind_phys), intent(inout) :: tgrs(1:ncol,1:nlev) - real(kind_phys), intent(in ) :: prsl(1:ncol,1:nlev) - real(kind_phys), intent(in ) :: prslk(1:ncol,1:nlev) - - ! Air density - real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 - ! Hydrometeors -! real(kind_phys) :: qv_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) -! real(kind_phys) :: qc_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) -! real(kind_phys) :: qr_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) -! real(kind_phys) :: qi_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) -! real(kind_phys) :: qs_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) -! real(kind_phys) :: qh_mp(1:ncol,1:nlev) !< kg kg-1 (graupel dry mixing ratio) - real(kind_phys) :: qhl_mp(1:ncol,1:nlev) !< kg kg-1 (hail dry mixing ratio) -! real(kind_phys) :: nc_mp(1:ncol,1:nlev) !< droplet num. conc. -! real(kind_phys) :: nr_mp(1:ncol,1:nlev) !< rain num. conc. -! real(kind_phys) :: ni_mp(1:ncol,1:nlev) !< ice crystal num. conc. -! real(kind_phys) :: ns_mp(1:ncol,1:nlev) !< snow num. conc. -! real(kind_phys) :: nh_mp(1:ncol,1:nlev) !< graupel num. conc. -! real(kind_phys) :: nhl_mp(1:ncol,1:nlev) !< hail num. conc. - real(kind_phys) :: vh_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) - real(kind_phys) :: cccn_mp(1:ncol,1:nlev) - real(kind_phys) :: cccna_mp(1:ncol,1:nlev) - ! create temporaries for hail in case it does not exist - real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) - real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) - - real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array ! Local variables: dimensions used in nssl_init integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k real :: nssl_params(20) @@ -116,16 +64,14 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ! write(0,*) 'nssl_init: nlev,ncol,rank = ',nlev,ncol,mpirank - if (is_initialized .and. .not. first_time_step ) return + if ( is_initialized ) return IF ( .not. is_initialized ) THEN ! only do this on first call if (mpirank==mpiroot) then write(0,*) ' ----------------------------------------------------------------------------------------------------------------' write(0,*) ' --- CCPP NSSL MP scheme init ---' -! write(0,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development --- WARNING ---' write(0,*) ' ----------------------------------------------------------------------------------------------------------------' write(6,*) ' ----------------------------------------------------------------------------------------------------------------' -! write(6,*) ' --- WARNING! --- the CCPP NSSL MP scheme is currently under development --- WARNING ---' write(6,*) ' --- CCPP NSSL MP scheme init ---' write(6,*) ' ----------------------------------------------------------------------------------------------------------------' end if @@ -137,7 +83,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & return end if - ! set physical constants + ! set some physical constants in NSSL microphysics to be consistent with parent model call nssl_2mom_init_const( & con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) @@ -179,111 +125,15 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ihailv = -1 ENDIF - IF ( imp_physics == imp_physics_nssl ) THEN ! ( .not. nssl_ccn_flag ) ! write(0,*) 'call nssl_2mom_init' CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & ihvol=ihailv,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) -! write(0,*) 'done nssl_2mom_init' -! ELSE -! write(0,*) 'call nssl_2mom_init ccn: imp_physics, imp_physics_nssl2mccn = ',imp_physics, imp_physics_nssl2mccn -! CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=ihailv) -! write(0,*) 'done nssl_2mom_init ccn' - ENDIF - - is_initialized = .true. - - ENDIF ! .not. is_initialized - -#if 0 -! IF ( is_initialized .and. ((.not. first_time_step) .or. restart ) ) THEN -! return -! ENDIF - - ! Following code only runs on first time step -- hopefully for all slabs - !> - Density of air in kg m-3 - rho = prsl/(con_rd*tgrs) - allocate( an(nx,1,nz,na) ) - an(:,:,:,:) = 0.0 - -! spechum, qc, qr, qi, qs, qh, qhl, & -! cccn, cccna, ccw, crw, cci, csw, chw, chl, vh, vhl, tgrs, prslk, prsl ) - - ! use local arrays for variables that might not exist - ! implied loops - IF ( nssl_hail_on ) THEN - qhl_mp = qhl - vhl_mp = vhl - chl_mp = chl - ELSE - qhl_mp = 0 - vhl_mp = 0 - chl_mp = 0 - ENDIF - IF ( nssl_ccn_on ) THEN - cccn_mp = nssl_qccn ! cccn - cccna_mp = 0 - ELSE - cccn_mp = nssl_qccn - cccna_mp = 0 - ENDIF -! qr_mp = qr -! qs_mp = qs -! write(0,*) 'mp_nssl_init1: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh),maxval(rho) -! write(0,*) 'mp_nssl_init: call calcnfromq',restart,is_initialized,first_time_step - call calcnfromq(nx=nx,ny=1,nz=nz,an=an,na=na,nor=0,norz=0,dn=rho, & - & qcw=qc,qci=qi,qsw=qs,qrw=qr,qhw=qh,qhl=qhl_mp, & - & ccw=ccw,cci=cci,csw=csw,crw=crw,chw=chw,chl=chl_mp, & - & cccn=cccn_mp,cccna=cccna_mp, vhw=vh,vhl=vhl_mp ) - -! qr = qr_mp -! qs = qs_mp - - ! write(0,*) 'mp_nssl_init2: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh),maxval(rho) - ! write(0,*) 'mp_nssl_init2: ni,ns,nh maxval: ',maxval(cci),maxval(csw),maxval(chw) -! DO k = 1,nz -! DO i = 1,nx -! IF ( qi(i,k) > 1.e-4 ) write(6,*) 'qi,ni = ',qi(i,k),cci(i,k) -! IF ( qs(i,k) > 1.e-3 ) write(6,*) 'qs,ns = ',qs(i,k),csw(i,k) -! IF ( qh(i,k) > 1.e-3 ) write(6,*) 'qh,nh = ',qh(i,k),chw(i,k) -! ENDDO -! ENDDO - - IF ( nssl_hail_on ) THEN - qhl = qhl_mp - vhl = vhl_mp - chl = chl_mp - ENDIF - IF ( nssl_ccn_on ) THEN - IF ( nssl_invertccn ) THEN - !cccn = cccna_mp - DO k = 1,nlev - DO i = 1,ncol - cccn(i,k) = nssl_qccn - cccn_mp(i,k) - ENDDO - ENDDO - ELSE - cccn = cccn_mp - ENDIF - ENDIF - -! qs = 0 -! qi = 0 -! qr = 0 - -! call calc_eff_radius & -! & (nx=im,ny=1,nz=lm,na=1,jyslab=1 & -! & ,nor=0,norz=0 & -! & ,t1=re_cloud,t2=re_ice,t3=re_snow,t4=re_rain & -! & ,qcw=qc_mp,qci=qi_mp,qsw=qs_mp,qrw=qr_mp & -! & ,ccw=nc_mp,cci=ni_mp,csw=ns_mp,crw=nr_mp & -! & ,dn=rho ) + is_initialized = .true. - - deallocate( an ) -#endif + ENDIF ! .not. is_initialized return @@ -303,6 +153,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, & re_cloud, re_ice, re_snow, re_rain, & + nleffr, nieffr, nseffr, nreffr, & imp_physics, convert_dry_rho, & imp_physics_nssl, nssl_ccn_on, & nssl_hail_on, nssl_invertccn, ntccn, ntccna, & @@ -352,10 +203,11 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & real(kind_phys), intent(inout) :: refl_10cm(1:ncol,1:nlev) logical, intent(in ) :: do_radar_ref, first_time_step ! Cloud effective radii - real(kind_phys), optional, intent(inout) :: re_cloud(:,:) ! (1:ncol,1:nlev) - real(kind_phys), optional, intent(inout) :: re_ice(:,:) ! (1:ncol,1:nlev) - real(kind_phys), optional, intent(inout) :: re_snow(:,:) ! (1:ncol,1:nlev) - real(kind_phys), optional, intent(inout) :: re_rain(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_cloud(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_ice(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_snow(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_rain(:,:) ! (1:ncol,1:nlev) + integer, intent(in) :: nleffr, nieffr, nseffr, nreffr integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn @@ -447,7 +299,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ! write(0,*) 'nssl_run: nlev,ncol,rank = ',nlev,ncol,mpirank - IF ( ndebug > 1 ) write(0,*) 'In physics nssl_run' + IF ( ndebug >= 1 ) write(0,*) 'In physics nssl_run' ! Check initialization state @@ -559,8 +411,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & xdelta_graupel_mp = 0 xdelta_ice_mp = 0 xdelta_snow_mp = 0 - - IF ( ndebug >= 1 ) THEN + IF ( ndebug > 1 ) THEN write(*,*) 'Max q before micro' write(*,*) 'qc = ',1000.*maxval(qc_mp) write(*,*) 'qr = ',1000.*maxval(qr_mp) @@ -580,13 +431,15 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & do_radar_ref_mp = 0 end if - if (present(re_cloud) .and. present(re_ice) .and. present(re_snow)) then + do_effective_radii = .false. + IF ( nleffr > 0 .and. nieffr > 0 .and. nseffr > 0 .and. nreffr > 0 ) THEN + ! if (present(re_cloud) .and. present(re_ice) .and. present(re_snow)) then do_effective_radii = .true. has_reqc = 1 has_reqi = 1 has_reqs = 1 - IF ( present( re_rain ) ) has_reqr = 1 - else if (.not.present(re_cloud) .and. .not.present(re_ice) .and. .not.present(re_snow)) then + has_reqr = 1 + else if (nleffr < 1 .and. nieffr < 1 .and. nseffr < 1 .and. nreffr < 1 ) then do_effective_radii = .false. has_reqc = 0 has_reqi = 0 @@ -594,8 +447,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & has_reqr = 0 else write(errmsg,fmt='(*(a))') 'Logic error in mp_nssl_run:', & - ' all or none of the following optional', & - ' arguments are required: re_cloud, re_ice, re_snow' + ' hydrometeor radius calculation logic problem' errflg = 1 return end if @@ -626,7 +478,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & kte = nlev - IF ( ndebug > 1 ) write(0,*) 'call nssl_2mom_driver' + IF ( ndebug >= 1 ) write(0,*) 'call nssl_2mom_driver' IF ( dtp > 1.5*dtpmax ) THEN ntmul = Nint( dtp/dtpmax ) @@ -650,7 +502,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & itimestep = 2 ENDIF - IF ( .false. ) THEN + IF ( .false. ) THEN ! disable for now, as logic in the NSSL driver does this, but may switch back to here ! incoming droplet field may have some inconsistent number concentrations (e.g., from PBL) ! so check for that, otherwise mass may be zapped into vapor allocate( an(ncol,1,nlev,na) ) @@ -854,7 +706,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & if (errflg/=0) return - IF ( ndebug >= 1 ) THEN + IF ( ndebug > 1 ) THEN write(*,*) 'Max q after micro' write(*,*) 'qc = ',1000.*maxval(qc_mp) write(*,*) 'qr = ',1000.*maxval(qr_mp) @@ -946,7 +798,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & re_rain = re_rain_mp*1.0E6_kind_phys end if - IF ( ndebug > 1 ) write(0,*) 'mp_nssl: end' + IF ( ndebug >= 1 ) write(0,*) 'mp_nssl: end' end subroutine mp_nssl_run !>@} diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 4d3f3b00f..2e5b3e017 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -151,14 +151,6 @@ type = integer intent = in optional = F -[convert_dry_rho] - standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air - long_name = flag for converting hydrometeors from moist to dry air - units = flag - dimensions = () - type = logical - intent = in - optional = F [imp_physics_nssl] standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme @@ -218,195 +210,6 @@ type = logical intent = in optional = F -[first_time_step] - standard_name = flag_for_first_timestep - long_name = flag for first time step for time integration loop (cold/warmstart) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[spechum] - standard_name = specific_humidity - long_name = water vapor specific humidity - units = kg kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[qhl] - standard_name = hail_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of hail - units = kg kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[cccn] - standard_name = cloud_condensation_nuclei_number_concentration - long_name = number concentration of cloud condensation nuclei - units = kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[cccna] - standard_name = activated_cloud_condensation_nuclei_number_concentration - long_name = number concentration of activated cloud condensation nuclei - units = kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[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 - optional = F -[chl] - standard_name = mass_number_concentration_of_hail_in_air - long_name = hail number concentration - units = kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[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 - optional = F -[vhl] - standard_name = hail_volume - long_name = hail particle volume - units = m3 kg-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[prslk] - standard_name = dimensionless_exner_function - long_name = dimensionless Exner function at model layer centers - units = none - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_dimension,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in - optional = F - ######################################################################## [ccpp-arg-table] name = mp_nssl_run @@ -747,7 +550,7 @@ type = real kind = kind_phys intent = inout - optional = T + optional = F [re_ice] standard_name = effective_radius_of_stratiform_cloud_ice_particle long_name = eff. radius of cloud ice water particle in micrometer @@ -756,7 +559,7 @@ type = real kind = kind_phys intent = inout - optional = T + optional = F [re_snow] standard_name = effective_radius_of_stratiform_cloud_snow_particle long_name = effective radius of cloud snow particle in micrometer @@ -765,7 +568,7 @@ type = real kind = kind_phys intent = inout - optional = T + optional = F [re_rain] standard_name = effective_radius_of_stratiform_cloud_rain_particle long_name = effective radius of cloud rain particle in micrometers @@ -774,7 +577,39 @@ type = real kind = kind_phys intent = inout - optional = T + optional = F +[nleffr] + standard_name = index_of_cloud_liquid_water_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of cloud liquid water effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in + optional = F +[nieffr] + standard_name = index_of_cloud_ice_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of ice effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in + optional = F +[nreffr] + standard_name = index_of_rain_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of rain effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in + optional = F +[nseffr] + standard_name = index_of_snow_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of snow effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in + optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme From 938d5f24bc3a5c5e92a895fa87749428dc85cac2 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Tue, 19 Oct 2021 12:51:10 -0500 Subject: [PATCH 053/217] Added dependencies to RUC physics --- physics/radiation_surface.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/radiation_surface.meta b/physics/radiation_surface.meta index beab83ce9..668a2bd21 100644 --- a/physics/radiation_surface.meta +++ b/physics/radiation_surface.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = module_radiation_surface type = module - dependencies = + dependencies = namelist_soilveg_ruc.F90,set_soilveg_ruc.F90 ######################################################################## [ccpp-arg-table] From 906248eb1fdbb92737fc328c5eeb324caa282ac3 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 8 Dec 2021 17:04:08 -0600 Subject: [PATCH 054/217] Removed a bunch of "optional = F" from meta files. --- physics/GFS_DCNV_generic.meta | 8 --- physics/GFS_MP_generic.meta | 1 - physics/GFS_PBL_generic.meta | 16 ----- physics/GFS_rrtmg_pre.meta | 25 -------- physics/GFS_suite_interstitial.meta | 7 --- physics/maximum_hourly_diagnostics.meta | 1 - physics/module_MYNNPBL_wrapper.meta | 4 -- physics/mp_nssl.meta | 81 ------------------------- physics/sfc_drv_ruc.meta | 1 - 9 files changed, 144 deletions(-) diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index eb9bba6cf..ec784707d 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -239,7 +239,6 @@ dimensions = () type = integer intent = in - optional = F [nthnc] standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array long_name = tracer index for hail number concentration @@ -247,7 +246,6 @@ dimensions = () type = integer intent = in - optional = F [ntgv] standard_name = index_of_graupel_volume_in_tracer_concentration_array long_name = tracer index for graupel particle volume @@ -255,7 +253,6 @@ dimensions = () type = integer intent = in - optional = F [nthv] standard_name = index_of_hail_volume_in_tracer_concentration_array long_name = tracer index for hail particle volume @@ -263,7 +260,6 @@ dimensions = () type = integer intent = in - optional = F [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers @@ -723,7 +719,6 @@ dimensions = () type = integer intent = in - optional = F [nthnc] standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array long_name = tracer index for hail number concentration @@ -731,7 +726,6 @@ dimensions = () type = integer intent = in - optional = F [ntgv] standard_name = index_of_graupel_volume_in_tracer_concentration_array long_name = tracer index for graupel particle volume @@ -739,7 +733,6 @@ dimensions = () type = integer intent = in - optional = F [nthv] standard_name = index_of_hail_volume_in_tracer_concentration_array long_name = tracer index for hail particle volume @@ -747,7 +740,6 @@ dimensions = () type = integer intent = in - optional = F [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index f10b02948..9cb5ab2b7 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -220,7 +220,6 @@ dimensions = () type = integer intent = in - optional = F [cal_pre] standard_name = flag_for_dominant_precipitation_type_partition long_name = flag controls precip type algorithm diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index eeb68c74f..688721f21 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -189,7 +189,6 @@ dimensions = () type = integer intent = in - optional = F [nthl] standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array long_name = tracer index for hail @@ -197,7 +196,6 @@ dimensions = () type = integer intent = in - optional = F [nthnc] standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array long_name = tracer index for hail number concentration @@ -205,7 +203,6 @@ dimensions = () type = integer intent = in - optional = F [ntgv] standard_name = index_of_graupel_volume_in_tracer_concentration_array long_name = tracer index for graupel particle volume @@ -213,7 +210,6 @@ dimensions = () type = integer intent = in - optional = F [nthv] standard_name = index_of_hail_volume_in_tracer_concentration_array long_name = tracer index for hail particle volume @@ -221,7 +217,6 @@ dimensions = () type = integer intent = in - optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -278,7 +273,6 @@ dimensions = () type = integer intent = in - optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -293,7 +287,6 @@ dimensions = () type = logical intent = in - optional = F [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro @@ -301,7 +294,6 @@ dimensions = () type = logical intent = in - optional = F [hybedmf] standard_name = flag_for_hybrid_edmf_pbl_scheme long_name = flag for hybrid edmf pbl scheme (moninedmf) @@ -624,7 +616,6 @@ dimensions = () type = integer intent = in - optional = F [nthl] standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array long_name = tracer index for hail @@ -632,7 +623,6 @@ dimensions = () type = integer intent = in - optional = F [nthnc] standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array long_name = tracer index for hail number concentration @@ -640,7 +630,6 @@ dimensions = () type = integer intent = in - optional = F [ntgv] standard_name = index_of_graupel_volume_in_tracer_concentration_array long_name = tracer index for graupel particle volume @@ -648,7 +637,6 @@ dimensions = () type = integer intent = in - optional = F [nthv] standard_name = index_of_hail_volume_in_tracer_concentration_array long_name = tracer index for hail particle volume @@ -656,7 +644,6 @@ dimensions = () type = integer intent = in - optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -713,7 +700,6 @@ dimensions = () type = integer intent = in - optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -728,7 +714,6 @@ dimensions = () type = logical intent = in - optional = F [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro @@ -736,7 +721,6 @@ dimensions = () type = logical intent = in - optional = F [cplflx] standard_name = flag_for_surface_flux_coupling long_name = flag controlling cplflx collection (default off) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index c14fe77af..31da38c88 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -149,7 +149,6 @@ dimensions = () type = integer intent = in - optional = F [ntsnc] standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array long_name = tracer index for snow number concentration @@ -157,7 +156,6 @@ dimensions = () type = integer intent = in - optional = F [ntrw] standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array long_name = tracer index for rain water @@ -186,7 +184,6 @@ dimensions = () type = integer intent = in - optional = F [ntccn] standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration @@ -194,7 +191,6 @@ dimensions = () type = integer intent = in - optional = F [ntwa] standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array long_name = tracer index for water friendly aerosol @@ -216,7 +212,6 @@ dimensions = () type = logical intent = in - optional = F [nssl_invertccn] standard_name = nssl_invertccn long_name = flag to invert CCN in NSSL micro @@ -224,7 +219,6 @@ dimensions = () type = logical intent = in - optional = F [ntclamt] standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array long_name = tracer index for cloud amount integer @@ -267,7 +261,6 @@ dimensions = () type = integer intent = in - optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -275,22 +268,6 @@ dimensions = () type = integer intent = in -[imp_physics_nssl2m] - standard_name = flag_for_nssl2m_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_nssl2mccn] - standard_name = flag_for_nssl2mccn_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme with CCN - units = flag - dimensions = () - type = integer - intent = in - optional = F [imp_physics_nssl] standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme @@ -298,7 +275,6 @@ dimensions = () type = integer intent = in - optional = F [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme @@ -1122,4 +1098,3 @@ dimensions = () type = integer intent = out - optional = F diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 251ca49f9..dc2965ab9 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1047,7 +1047,6 @@ dimensions = (number_of_tracers_plus_one) type = logical intent = in - optional = F [im] standard_name = horizontal_loop_extent long_name = horizontal loop extent @@ -1269,7 +1268,6 @@ dimensions = () type = integer intent = in - optional = F [prsi] standard_name = air_pressure_at_interface long_name = air pressure at model layer interfaces @@ -1627,7 +1625,6 @@ dimensions = () type = integer intent = in - optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -1677,7 +1674,6 @@ dimensions = () type = integer intent = in - optional = F [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro @@ -1685,7 +1681,6 @@ dimensions = () type = logical intent = in - optional = F [nssl_invertccn] standard_name = nssl_invertccn long_name = flag to invert CCN in NSSL micro @@ -1693,7 +1688,6 @@ dimensions = () type = logical intent = in - optional = F [dtf] standard_name = timestep_for_dynamics long_name = dynamics timestep @@ -1863,7 +1857,6 @@ dimensions = (number_of_tracers_plus_one) type = logical intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 48fb74b1f..722eefb8e 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -70,7 +70,6 @@ dimensions = () type = integer intent = in - optional = F [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 4516803f0..e62caf017 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -344,7 +344,6 @@ type = real kind = kind_phys intent = inout - optional = F [prsl] standard_name = air_pressure long_name = mean layer pressure @@ -1011,7 +1010,6 @@ type = real kind = kind_phys intent = inout - optional = F [flag_for_pbl_generic_tend] standard_name = flag_for_generic_tendency_due_to_planetary_boundary_layer long_name = true if GFS_PBL_generic should calculate tendencies @@ -1282,7 +1280,6 @@ dimensions = () type = integer intent = in - optional = F [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro @@ -1290,7 +1287,6 @@ dimensions = () type = logical intent = in - optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 2e5b3e017..8f2a4141d 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -13,7 +13,6 @@ dimensions = () type = integer intent = in - optional = F [nlev] standard_name = vertical_layer_dimension long_name = number of vertical levels @@ -21,7 +20,6 @@ dimensions = () type = integer intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -30,7 +28,6 @@ type = character kind = len=* intent = out - optional = F [errflg] standard_name = ccpp_error_flag long_name = error flag for error handling in CCPP @@ -38,7 +35,6 @@ dimensions = () type = integer intent = out - optional = F [threads] standard_name = number_of_openmp_threads long_name = number of OpenMP threads available to scheme @@ -46,7 +42,6 @@ dimensions = () type = integer intent = in - optional = F [restart] standard_name = flag_for_restart long_name = flag for restart (warmstart) or coldstart @@ -54,7 +49,6 @@ dimensions = () type = logical intent = in - optional = F [mpirank] standard_name = mpi_rank long_name = current MPI-rank @@ -62,7 +56,6 @@ dimensions = () type = integer intent = in - optional = F [mpiroot] standard_name = mpi_root long_name = master MPI-rank @@ -70,7 +63,6 @@ dimensions = () type = integer intent = in - optional = F [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -79,7 +71,6 @@ type = real kind = kind_phys intent = in - optional = F [con_rd] standard_name = gas_constant_of_dry_air long_name = ideal gas constant for dry air @@ -88,7 +79,6 @@ type = real kind = kind_phys intent = in - optional = F [con_cp] standard_name = specific_heat_of_dry_air_at_constant_pressure long_name = specific heat of dry air at constant pressure @@ -97,7 +87,6 @@ type = real kind = kind_phys intent = in - optional = F [con_rv] standard_name = gas_constant_water_vapor long_name = ideal gas constant for water vapor @@ -106,7 +95,6 @@ type = real kind = kind_phys intent = in - optional = F [con_t0c] standard_name = temperature_at_zero_celsius long_name = temperature at 0 degree Celsius @@ -115,7 +103,6 @@ type = real kind = kind_phys intent = in - optional = F [con_cliq] standard_name = specific_heat_of_liquid_water_at_constant_pressure long_name = specific heat of liquid water at constant pressure @@ -124,7 +111,6 @@ type = real kind = kind_phys intent = in - optional = F [con_csol] standard_name = specific_heat_of_ice_at_constant_pressure long_name = specific heat of ice at constant pressure @@ -133,7 +119,6 @@ type = real kind = kind_phys intent = in - optional = F [con_eps] standard_name = ratio_of_dry_air_to_water_vapor_gas_constants long_name = rd/rv @@ -142,7 +127,6 @@ type = real kind = kind_phys intent = in - optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -150,7 +134,6 @@ dimensions = () type = integer intent = in - optional = F [imp_physics_nssl] standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme @@ -158,7 +141,6 @@ dimensions = () type = integer intent = in - optional = F [nssl_cccn] standard_name = nssl_ccn_concentration long_name = CCN concentration @@ -167,7 +149,6 @@ type = real kind = kind_phys intent = in - optional = F [nssl_alphah] standard_name = nssl_alpha_graupel long_name = graupel PSD shape parameter in NSSL micro @@ -176,7 +157,6 @@ type = real kind = kind_phys intent = in - optional = F [nssl_alphahl] standard_name = nssl_alpha_hail long_name = hail PSD shape parameter in NSSL micro @@ -185,7 +165,6 @@ type = real kind = kind_phys intent = in - optional = F [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro @@ -193,7 +172,6 @@ dimensions = () type = logical intent = in - optional = F [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro @@ -201,7 +179,6 @@ dimensions = () type = logical intent = in - optional = F [nssl_invertccn] standard_name = nssl_invertccn long_name = flag to invert CCN in NSSL micro @@ -209,7 +186,6 @@ dimensions = () type = logical intent = in - optional = F ######################################################################## [ccpp-arg-table] name = mp_nssl_run @@ -221,7 +197,6 @@ dimensions = () type = integer intent = in - optional = F [nlev] standard_name = vertical_layer_dimension long_name = number of vertical levels @@ -229,7 +204,6 @@ dimensions = () type = integer intent = in - optional = F [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -238,7 +212,6 @@ type = real kind = kind_phys intent = in - optional = F [con_rd] standard_name = gas_constant_of_dry_air long_name = ideal gas constant for dry air @@ -247,7 +220,6 @@ type = real kind = kind_phys intent = in - optional = F [mpirank] standard_name = mpi_rank long_name = current MPI-rank @@ -255,7 +227,6 @@ dimensions = () type = integer intent = in - optional = F [spechum] standard_name = specific_humidity_of_new_state long_name = water vapor specific humidity @@ -264,7 +235,6 @@ type = real kind = kind_phys intent = inout - optional = F [qc] standard_name = cloud_liquid_water_mixing_ratio_of_new_state long_name = cloud water mixing ratio wrt dry+vapor (no condensates) @@ -273,7 +243,6 @@ type = real kind = kind_phys intent = inout - optional = F [qr] standard_name = rain_mixing_ratio_of_new_state long_name = rain water mixing ratio wrt dry+vapor (no condensates) @@ -282,7 +251,6 @@ type = real kind = kind_phys intent = inout - optional = F [qi] standard_name = cloud_ice_mixing_ratio_of_new_state long_name = ice water mixing ratio wrt dry+vapor (no condensates) @@ -291,7 +259,6 @@ type = real kind = kind_phys intent = inout - optional = F [qs] standard_name = snow_mixing_ratio_of_new_state long_name = snow water mixing ratio wrt dry+vapor (no condensates) @@ -300,7 +267,6 @@ type = real kind = kind_phys intent = inout - optional = F [qh] standard_name = graupel_mixing_ratio_of_new_state long_name = graupel mixing ratio wrt dry+vapor (no condensates) @@ -309,7 +275,6 @@ type = real kind = kind_phys intent = inout - optional = F [qhl] standard_name = hail_mixing_ratio_of_new_state long_name = moist (dry+vapor, no condensates) mixing ratio of hail updated by physics @@ -318,7 +283,6 @@ type = real kind = kind_phys intent = inout - optional = F [cccn] standard_name = cloud_condensation_nuclei_number_concentration_of_new_state long_name = number concentration of cloud condensation nuclei updated by physics @@ -327,7 +291,6 @@ type = real kind = kind_phys intent = inout - optional = F [cccna] standard_name = activated_cloud_condensation_nuclei_number_concentration_of_new_state long_name = number concentration of activated cloud condensation nuclei updated by physics @@ -336,7 +299,6 @@ type = real kind = kind_phys intent = inout - optional = F [ccw] standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air_of_new_state long_name = cloud droplet number concentration @@ -345,7 +307,6 @@ type = real kind = kind_phys intent = inout - optional = F [crw] standard_name = mass_number_concentration_of_rain_of_new_state long_name = rain number concentration @@ -354,7 +315,6 @@ type = real kind = kind_phys intent = inout - optional = F [cci] standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air_of_new_state long_name = ice number concentration @@ -363,7 +323,6 @@ type = real kind = kind_phys intent = inout - optional = F [csw] standard_name = mass_number_concentration_of_snow_of_new_state long_name = snow number concentration @@ -372,7 +331,6 @@ type = real kind = kind_phys intent = inout - optional = F [chw] standard_name = mass_number_concentration_of_graupel_of_new_state long_name = graupel number concentration @@ -381,7 +339,6 @@ type = real kind = kind_phys intent = inout - optional = F [chl] standard_name = mass_number_concentration_of_hail_of_new_state long_name = hail number concentration @@ -390,7 +347,6 @@ type = real kind = kind_phys intent = inout - optional = F [vh] standard_name = graupel_volume_of_new_state long_name = graupel particle volume @@ -399,7 +355,6 @@ type = real kind = kind_phys intent = inout - optional = F [vhl] standard_name = hail_volume_of_new_state long_name = hail particle volume @@ -408,7 +363,6 @@ type = real kind = kind_phys intent = inout - optional = F [tgrs] standard_name = air_temperature_of_new_state long_name = model layer mean temperature @@ -417,7 +371,6 @@ type = real kind = kind_phys intent = inout - optional = F [prslk] standard_name = dimensionless_exner_function long_name = dimensionless Exner function at model layer centers @@ -426,7 +379,6 @@ type = real kind = kind_phys intent = in - optional = F [prsl] standard_name = air_pressure long_name = mean layer pressure @@ -435,7 +387,6 @@ type = real kind = kind_phys intent = in - optional = F [phii] standard_name = geopotential_at_interface long_name = geopotential at model layer interfaces @@ -444,7 +395,6 @@ type = real kind = kind_phys intent = in - optional = F [omega] standard_name = lagrangian_tendency_of_air_pressure long_name = layer mean vertical velocity @@ -453,7 +403,6 @@ type = real kind = kind_phys intent = in - optional = F [dtp] standard_name = timestep_for_physics long_name = physics timestep @@ -462,7 +411,6 @@ type = real kind = kind_phys intent = in - optional = F [prcp] standard_name = lwe_thickness_of_explicit_precipitation_amount long_name = explicit precipitation (rain, ice, snow, graupel) on physics timestep @@ -471,7 +419,6 @@ type = real kind = kind_phys intent = inout - optional = F [rain] standard_name = lwe_thickness_of_explicit_rain_amount long_name = explicit rain fall on physics timestep @@ -480,7 +427,6 @@ type = real kind = kind_phys intent = inout - optional = F [graupel] standard_name = lwe_thickness_of_graupel_amount long_name = graupel fall on physics timestep @@ -489,7 +435,6 @@ type = real kind = kind_phys intent = inout - optional = F [ice] standard_name = lwe_thickness_of_ice_amount long_name = ice fall on physics timestep @@ -498,7 +443,6 @@ type = real kind = kind_phys intent = inout - optional = F [snow] standard_name = lwe_thickness_of_snow_amount long_name = snow fall on physics timestep @@ -507,7 +451,6 @@ type = real kind = kind_phys intent = inout - optional = F [sr] standard_name = ratio_of_snowfall_to_rainfall long_name = ratio of snowfall to large-scale rainfall @@ -516,7 +459,6 @@ type = real kind = kind_phys intent = out - optional = F [refl_10cm] standard_name = radar_reflectivity_10cm long_name = instantaneous refl_10cm @@ -525,7 +467,6 @@ type = real kind = kind_phys intent = out - optional = F [do_radar_ref] standard_name = flag_for_radar_reflectivity long_name = flag for radar reflectivity @@ -533,7 +474,6 @@ dimensions = () type = logical intent = in - optional = F [first_time_step] standard_name = flag_for_first_timestep long_name = flag for first time step for time integration loop (cold/warmstart) @@ -541,7 +481,6 @@ dimensions = () type = logical intent = in - optional = F [re_cloud] standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle long_name = eff. radius of cloud liquid water particle in micrometer @@ -550,7 +489,6 @@ type = real kind = kind_phys intent = inout - optional = F [re_ice] standard_name = effective_radius_of_stratiform_cloud_ice_particle long_name = eff. radius of cloud ice water particle in micrometer @@ -559,7 +497,6 @@ type = real kind = kind_phys intent = inout - optional = F [re_snow] standard_name = effective_radius_of_stratiform_cloud_snow_particle long_name = effective radius of cloud snow particle in micrometer @@ -568,7 +505,6 @@ type = real kind = kind_phys intent = inout - optional = F [re_rain] standard_name = effective_radius_of_stratiform_cloud_rain_particle long_name = effective radius of cloud rain particle in micrometers @@ -577,7 +513,6 @@ type = real kind = kind_phys intent = inout - optional = F [nleffr] standard_name = index_of_cloud_liquid_water_effective_radius_in_xyz_dimensioned_restart_array long_name = the index of cloud liquid water effective radius in phy_f3d @@ -585,7 +520,6 @@ dimensions = () type = integer intent = in - optional = F [nieffr] standard_name = index_of_cloud_ice_effective_radius_in_xyz_dimensioned_restart_array long_name = the index of ice effective radius in phy_f3d @@ -593,7 +527,6 @@ dimensions = () type = integer intent = in - optional = F [nreffr] standard_name = index_of_rain_effective_radius_in_xyz_dimensioned_restart_array long_name = the index of rain effective radius in phy_f3d @@ -601,7 +534,6 @@ dimensions = () type = integer intent = in - optional = F [nseffr] standard_name = index_of_snow_effective_radius_in_xyz_dimensioned_restart_array long_name = the index of snow effective radius in phy_f3d @@ -609,7 +541,6 @@ dimensions = () type = integer intent = in - optional = F [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -617,7 +548,6 @@ dimensions = () type = integer intent = in - optional = F [convert_dry_rho] standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air long_name = flag for converting hydrometeors from moist to dry air @@ -625,7 +555,6 @@ dimensions = () type = logical intent = in - optional = F [imp_physics_nssl] standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme @@ -633,7 +562,6 @@ dimensions = () type = integer intent = in - optional = F [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro @@ -641,7 +569,6 @@ dimensions = () type = logical intent = in - optional = F [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro @@ -649,7 +576,6 @@ dimensions = () type = logical intent = in - optional = F [nssl_invertccn] standard_name = nssl_invertccn long_name = flag to invert CCN in NSSL micro @@ -657,7 +583,6 @@ dimensions = () type = logical intent = in - optional = F [ntccn] standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration @@ -665,7 +590,6 @@ dimensions = () type = integer intent = in - optional = F [ntccna] standard_name = index_of_activated_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for activated cloud condensation nuclei number concentration @@ -673,7 +597,6 @@ dimensions = () type = integer intent = in - optional = F [errflg] standard_name = ccpp_error_flag long_name = error flag for error handling in CCPP @@ -681,7 +604,6 @@ dimensions = () type = integer intent = out - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -690,7 +612,6 @@ type = character kind = len=* intent = out - optional = F ######################################################################## [ccpp-arg-table] @@ -704,7 +625,6 @@ type = character kind = len=* intent = out - optional = F [errflg] standard_name = ccpp_error_flag long_name = error flag for error handling in CCPP @@ -712,5 +632,4 @@ dimensions = () type = integer intent = out - optional = F diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 75f63f3d2..14d54ef63 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -619,7 +619,6 @@ dimensions = () type = integer intent = in - optional = F [do_mynnsfclay] standard_name = flag_for_mellor_yamada_nakanishi_niino_surface_layer_scheme long_name = flag to activate MYNN surface layer From b88049ae2fe569574b54bd7e703a8d241b32e231 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 14 Jan 2022 19:30:23 -0600 Subject: [PATCH 055/217] Update progcld6 call for NSSL microphysics --- physics/GFS_rrtmg_pre.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 9cc18a38b..209107e59 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -1018,8 +1018,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & ntsw-1,ntgl-1, & im, lmk, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LMK), effrl_inout(:,:), & - effri_inout(:,:), effrs_inout(:,:), & + cldcov(:,1:LMK), cnvw, effrl_inout, & + effri_inout, effrs_inout, & + lwp_ex, iwp_ex, lwp_fc, iwp_fc, & dzb, xlat_d, julian, yearlen, & clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs endif ! MYNN PBL or GF From 68f97b10aba252ba1dd03bc2a39566831698e686 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 24 Jan 2022 18:01:19 +0000 Subject: [PATCH 056/217] Potential bug fix for RRTMGP GP flux coupling. --- physics/rrtmgp_sw_rte.F90 | 37 +++++++++++++++++++++++++++++-------- 1 file changed, 29 insertions(+), 8 deletions(-) diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index 1726d4bbd..ce555ffa6 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -88,7 +88,9 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz real(kind_phys), dimension(nday,NLev+1,sw_gas_props%get_nband()),target :: & fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_allsky, fluxSW_dn_clrsky, fluxSW_dn_dir_allsky real(kind_phys), dimension(ncol,NLev) :: vmrTemp - integer :: iBand + integer :: iBand, iDay,ibd + real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits + real(kind_phys), dimension(2), parameter :: nIR_uvvis_bnd = (/12850,16000/) ! Initialize CCPP error handling variables errmsg = '' @@ -105,17 +107,21 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz flux_clrsky%bnd_flux_up => fluxSW_up_clrsky flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky - ! *Note* Legacy RRTMG code. May need to revisit + ! Use near-IR albedo for bands with wavenumbers extending to 12850cm-1 + ! Use uv-vis albedo for bands with wavenumbers greater than 16000cm-1 + ! For overlapping band, average near-IR and us-vis albedos. + bandlimits = sw_gas_props%get_band_lims_wavenumber() do iBand=1,sw_gas_props%get_nband() - if (iBand .lt. 10) then + if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then sfc_alb_dir(iBand,:) = sfc_alb_nir_dir(iBand,idxday(1:nday)) sfc_alb_dif(iBand,:) = sfc_alb_nir_dif(iBand,idxday(1:nday)) endif - if (iBand .eq. 10) then + if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then sfc_alb_dir(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dir(iBand,idxday(1:nday)) + sfc_alb_uvvis_dir(iBand,idxday(1:nday))) sfc_alb_dif(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dif(iBand,idxday(1:nday)) + sfc_alb_uvvis_dif(iBand,idxday(1:nday))) + ibd = iBand endif - if (iBand .gt. 10) then + if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then sfc_alb_dir(iBand,:) = sfc_alb_uvvis_dir(iBand,idxday(1:nday)) sfc_alb_dif(iBand,:) = sfc_alb_uvvis_dif(iBand,idxday(1:nday)) endif @@ -153,12 +159,26 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (nCol,NLev,nBand) + ! Store fluxes fluxswUP_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_up,dim=3) fluxswDOWN_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_dn,dim=3) - scmpsw(idxday(1:nday))%nirbm = sum(flux_allsky%bnd_flux_dn_dir(1:nday,iSFC,:),dim=2) - scmpsw(idxday(1:nday))%nirdf = sum(flux_allsky%bnd_flux_dn( 1:nday,iSFC,:),dim=2) - & - sum(flux_allsky%bnd_flux_dn_dir(1:nday,iSFC,:),dim=2) + do iDay=1,nDay + ! Near IR + scmpsw(idxday(iDay))%nirbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. + scmpsw(idxday(iDay))%nirdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2.) - & + (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) + ! UV-VIS + scmpsw(idxday(iDay))%visbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. + scmpsw(idxday(iDay))%visdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2. ) - & + (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) + enddo else fluxswUP_allsky(:,:) = 0._kind_phys fluxswDOWN_allsky(:,:) = 0._kind_phys @@ -166,6 +186,7 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz fluxswDOWN_clrsky(:,:) = 0._kind_phys scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) endif + end subroutine rrtmgp_sw_rte_run ! ######################################################################################### From 6f43cc4ce1365f1719fd01a810d38392854842b2 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 26 Jan 2022 22:58:02 -0600 Subject: [PATCH 057/217] Update errflg --- physics/mp_nssl.meta | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 8f2a4141d..6e48363f4 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -29,9 +29,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -598,9 +598,9 @@ type = integer intent = in [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -626,9 +626,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out From 86592d1ea927ab42470ecc66e9ba47858d9d7d2c Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 26 Jan 2022 23:37:59 -0600 Subject: [PATCH 058/217] Remove extra blank lines and unneeded check for imp_physics=18 --- physics/GFS_rrtmg_pre.F90 | 6 ++---- physics/radiation_clouds.f | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index a6c64efdc..c8e11231b 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,7 +18,8 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, & + ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & imp_physics,imp_physics_nssl, nssl_ccn_on, nssl_invertccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & @@ -121,7 +122,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & cnvw_in, cnvc_in, & sppt_wts - real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs, aer_nm real(kind=kind_phys), dimension(:), intent(inout) :: coszen, coszdg @@ -655,7 +655,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water ccnd(i,k,2) = tracer1(i,k,ntiw) ! ice water ccnd(i,k,3) = tracer1(i,k,ntrw) ! rain water - if (imp_physics == imp_physics_fer_hires ) then ccnd(i,k,4) = 0.0 else @@ -1146,5 +1145,4 @@ subroutine GFS_rrtmg_pre_finalize () end subroutine GFS_rrtmg_pre_finalize !! @} - end module GFS_rrtmg_pre diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 62c1276a6..a31c06f01 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -391,7 +391,7 @@ subroutine cld_init & print *,' --- MG cloud microphysics' elseif (imp_physics == 15) then print *,' --- Ferrier-Aligo cloud microphysics' - elseif (imp_physics == 17 .or. imp_physics == 18) then + elseif (imp_physics == 17) then print *,' --- NSSL cloud microphysics' else print *,' !!! ERROR in cloud microphysc specification!!!', & From 4cbea925e49b885a8e7b63aa300cc13402f28a52 Mon Sep 17 00:00:00 2001 From: wx20hw Date: Sun, 30 Jan 2022 05:10:14 +0000 Subject: [PATCH 059/217] set up option for thermal roughness --- physics/module_sf_noahmp_glacier.f90 | 24 +++++++--- physics/module_sf_noahmplsm.f90 | 66 ++++++++++++++++++++++++++-- physics/noahmp_tables.f90 | 2 +- physics/sfc_noahmp_drv.F90 | 10 +++-- physics/sfc_noahmp_drv.meta | 7 +++ 5 files changed, 96 insertions(+), 13 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index 4c3a53c88..26dd810c7 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -62,6 +62,7 @@ module noahmp_glacier_globals INTEGER :: OPT_GLA != 1 !(suggested 1) INTEGER :: OPT_SFC != 1 !(suggested 1) + INTEGER :: OPT_TRS != 1 !(suggested 2) ! adjustable parameters for snow processes @@ -1129,8 +1130,10 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso real (kind=kind_phys) :: b !< temporary calculation real (kind=kind_phys) :: t, tdc !< kelvin to degree celsius with limit -50 to +50 real (kind=kind_phys), dimension( 1:nsoil) :: sice !< soil ice + real (kind=kind_phys) :: czil !< calculate roughness length of heat tdc(t) = min( 50., max(-50.,(t-tfrz)) ) + czil=0.5 ! ----------------------------------------------------------------- ! initialization variables that do not depend on stability iteration @@ -1155,10 +1158,18 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso fv = ur*vkc/log(zlvli/z0m) reyni = fv*z0m/(1.5e-05) !introduction of fv dependent z0h for the iter - if (reyni .gt. 2.0) then - z0h = z0m/exp(2.46*(reyni)**0.25 - log(7.4)) !Brutsaert 1982 - else - z0h = z0m/exp(-log(0.397)) !Brusaert 1982, table 4 + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + z0h = z0m*exp(-czil*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + z0h = z0m*0.0001 + elseif (opt_trs == 4) then + if (reyni .gt. 2.0) then + z0h = z0m/exp(2.46*(reyni)**0.25 - log(7.4)) !Brutsaert 1982 + else + z0h = z0m/exp(-log(0.397)) !Brusaert 1982, table 4 + endif endif z0h_total = z0h @@ -3328,7 +3339,8 @@ end subroutine error_glacier ! ================================================================================================== !>\ingroup NoahMP_LSM - subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iopt_gla, iopt_sfc) + subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iopt_gla,& + iopt_sfc, iopt_trs) implicit none @@ -3339,6 +3351,7 @@ subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iop !! 1 -> semi-implicit; 2 -> full implicit (original noah) integer, intent(in) :: iopt_gla !< glacier option (1->phase change; 2->simple) integer, intent(in) :: iopt_sfc !< sfc scheme option + integer, intent(in) :: iopt_trs !< thermal roughness option ! ------------------------------------------------------------------------------------------------- @@ -3348,6 +3361,7 @@ subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iop opt_stc = iopt_stc opt_gla = iopt_gla opt_sfc = iopt_sfc + opt_trs = iopt_trs end subroutine noahmp_options_glacier diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 944446085..b602a683e 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -159,6 +159,11 @@ module module_sf_noahmplsm ! **0 -> no crop model, will run default dynamic vegetation ! 1 -> liu, et al. 2016 + integer :: opt_trs !< options for thermal roughness scheme + ! **1 -> z0h=z0 + ! 2 -> czil + ! 3 -> ec style + ! 4 -> kb inversed !------------------------------------------------------------------------------------------! ! physical constants: ! !------------------------------------------------------------------------------------------! @@ -2241,6 +2246,21 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc q2e = fveg * q2v + (1.0 - fveg) * q2b + if (opt_trs == 1) then + z0wrf = fveg * z0m + (1.0 - fveg) * z0mg + z0hwrf = z0wrf + elseif (opt_trs == 2) then + z0wrf = fveg * z0m + (1.0 - fveg) * z0mg + z0hwrf = fveg * z0m*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0m)) & + +(1.0 - fveg) * z0mg*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0mg)) + elseif (opt_trs == 3) then + z0wrf = fveg * z0m + (1.0 - fveg) * z0mg + if (vegtyp.le.5) then + z0hwrf = fveg * z0m + (1.0 - fveg) * z0mg*0.1 + else + z0hwrf = fveg * z0m*0.01 + (1.0 - fveg) * z0mg*0.1 + endif + elseif (opt_trs == 4) then coeffa = (csigmaf0 - csigmaf1)/(1.0 - exp(-1.0*aone)) coeffb = csigmaf0 - coeffa csigmafveg = coeffa * exp(-1.0*aone*fveg) + coeffb @@ -2259,6 +2279,9 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in kbsigmafveg = csigmafveg/log((zlvl-ezpd)/z0wrf) - log((zlvl-ezpd)/z0wrf) z0hwrf = z0wrf/exp(kbsigmafveg) +! place holder doe other roughness scheme +! elseif (opt_trs == x) then + endif else taux = tauxb @@ -2283,7 +2306,19 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in chv = chb z0wrf = z0mg + if (opt_trs == 1) then + z0hwrf = z0wrf + elseif (opt_trs == 2) then + z0hwrf = z0wrf*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0wrf)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0hwrf = z0wrf + else + z0hwrf = z0wrf*0.01 + endif + elseif (opt_trs == 4) then z0hwrf =z0wrf/exp( csigmaf0/log((zlvl-ezpd)/z0wrf) - log((zlvl-ezpd)/z0wrf) ) + endif end if @@ -3965,11 +4000,22 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & cir = (2.-emv*(1.-emg))*emv*sb ! --------------------------------------------------------------------------------------------- + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0h = z0m + else + z0h = z0m*0.01 + endif + elseif (opt_trs == 4) then sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) kbsigmaf1 = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) z0h = z0m/exp(kbsigmaf1) csigmaf1 = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m)+kbsigmaf1) ! for output for interpolation - + endif ! -- tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) @@ -4582,7 +4628,19 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & csigmaf0 = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf0) - z0h = max(z0m/exp(kbsigmaf0),1.0e-6) + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0h = z0m + else + z0h = z0m*0.01 + endif + elseif (opt_trs == 4) then + z0h = max(z0m/exp(kbsigmaf0),1.0e-6) + endif ! ! for sfcdiff3; maybe should move to inside the option ! @@ -9782,7 +9840,7 @@ end subroutine psn_crop !>\ingroup NoahMP_LSM subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, & - iopt_rsf , iopt_soil, iopt_pedo, iopt_crop ) + iopt_rsf , iopt_soil, iopt_pedo, iopt_crop ,iopt_trs ) implicit none @@ -9804,6 +9862,7 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc integer, intent(in) :: iopt_soil !soil parameters set-up option integer, intent(in) :: iopt_pedo !pedo-transfer function (1->saxton and rawls) integer, intent(in) :: iopt_crop !crop model option (0->none; 1->liu et al.) + integer, intent(in) :: iopt_trs !thermal roughness scheme option (1->z0h=z0; 2->rb reversed) ! ------------------------------------------------------------------------------------------------- @@ -9824,6 +9883,7 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc opt_soil = iopt_soil opt_pedo = iopt_pedo opt_crop = iopt_crop + opt_trs = iopt_trs end subroutine noahmp_options diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 9cb25b3f3..5f6246a0f 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -735,7 +735,7 @@ module noahmp_tables real :: refkdt_table = 3.0 !< parameter in the surface runoff parameterization real :: frzk_table =0.15 !< frozen ground parameter real :: zbot_table = -8.0 !< depth [m] of lower boundary soil temperature - real :: czil_table = 0.1 !< parameter used in the calculation of the roughness length for heat + real :: czil_table = 0.5 !< parameter used in the calculation of the roughness length for heat ! mptable.tbl radiation parameters diff --git a/physics/sfc_noahmp_drv.F90 b/physics/sfc_noahmp_drv.F90 index 1fd9773ff..397a09674 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/sfc_noahmp_drv.F90 @@ -111,7 +111,7 @@ subroutine noahmpdrv_run & shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & - iopt_stc, xlatin, xcoszin, iyrlen, julian, garea, & + iopt_stc, iopt_trs,xlatin, xcoszin, iyrlen, julian, garea, & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, & con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & con_fvirt, con_rd, con_hfus, thsfc_loc, & @@ -213,6 +213,7 @@ subroutine noahmpdrv_run & integer , intent(in) :: iopt_snf ! option for partitioning precipitation into rainfall & snowfall integer , intent(in) :: iopt_tbot ! option for lower boundary condition of soil temperature integer , intent(in) :: iopt_stc ! option for snow/soil temperature time scheme (only layer 1) + integer , intent(in) :: iopt_trs ! option for thermal roughness scheme real(kind=kind_phys), dimension(:) , intent(in) :: xlatin ! latitude real(kind=kind_phys), dimension(:) , intent(in) :: xcoszin ! cosine of zenith angle integer , intent(in) :: iyrlen ! year length [days] @@ -700,8 +701,8 @@ subroutine noahmpdrv_run & call noahmp_options(idveg ,iopt_crs, iopt_btr , iopt_run, iopt_sfc, & iopt_frz, iopt_inf , iopt_rad, iopt_alb, & - iopt_snf, iopt_tbot, iopt_stc, & - iopt_rsf, iopt_soil, iopt_pedo, iopt_crop ) + iopt_snf, iopt_tbot, iopt_stc, iopt_rsf, & + iopt_soil,iopt_pedo, iopt_crop,iopt_trs ) if ( vegetation_category == isice_table ) then @@ -714,7 +715,8 @@ subroutine noahmpdrv_run & ice_flag = -1 temperature_soil_bot = min(temperature_soil_bot,263.15) - call noahmp_options_glacier(iopt_alb, iopt_snf, iopt_tbot, iopt_stc, iopt_gla, iopt_sfc ) + call noahmp_options_glacier(iopt_alb, iopt_snf, iopt_tbot, iopt_stc, iopt_gla, & + iopt_sfc ,iopt_trs) call noahmp_glacier ( & i_location ,1 ,cosine_zenith ,nsnow , & diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index e37036c32..712a457a6 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -424,6 +424,13 @@ dimensions = () type = integer intent = in +[iopt_trs] + standard_name = control_for_land_surface_scheme_surface_thermal_roughness + long_name = choice for surface thermal roughness option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in [xlatin] standard_name = latitude long_name = latitude From 22de66b8306b687585c5521367ab1a706e04209d Mon Sep 17 00:00:00 2001 From: wx20hw Date: Mon, 31 Jan 2022 17:08:50 +0000 Subject: [PATCH 060/217] change czil --- physics/module_sf_noahmp_glacier.f90 | 4 ++-- physics/noahmp_tables.f90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index 26dd810c7..c4c03aaf8 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -1133,7 +1133,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso real (kind=kind_phys) :: czil !< calculate roughness length of heat tdc(t) = min( 50., max(-50.,(t-tfrz)) ) - czil=0.5 + czil=0.1 ! ----------------------------------------------------------------- ! initialization variables that do not depend on stability iteration @@ -1163,7 +1163,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso elseif (opt_trs == 2) then z0h = z0m*exp(-czil*0.4*258.2*sqrt(fv*z0m)) elseif (opt_trs == 3) then - z0h = z0m*0.0001 + z0h = z0m*0.1 elseif (opt_trs == 4) then if (reyni .gt. 2.0) then z0h = z0m/exp(2.46*(reyni)**0.25 - log(7.4)) !Brutsaert 1982 diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 5f6246a0f..9cb25b3f3 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -735,7 +735,7 @@ module noahmp_tables real :: refkdt_table = 3.0 !< parameter in the surface runoff parameterization real :: frzk_table =0.15 !< frozen ground parameter real :: zbot_table = -8.0 !< depth [m] of lower boundary soil temperature - real :: czil_table = 0.5 !< parameter used in the calculation of the roughness length for heat + real :: czil_table = 0.1 !< parameter used in the calculation of the roughness length for heat ! mptable.tbl radiation parameters From be6335a77ad42df9537ada6ca66b1998b2722280 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 31 Jan 2022 14:07:46 -0700 Subject: [PATCH 061/217] standard name bugfixes for mp_nssl.meta and module_MYNNPBL_wrapper.meta --- physics/module_MYNNPBL_wrapper.meta | 4 ++-- physics/mp_nssl.meta | 3 +-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 39403aaa2..26620ea7f 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -340,7 +340,7 @@ standard_name = cloud_condensation_nuclei_number_concentration long_name = number concentration of cloud condensation nuclei units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -1006,7 +1006,7 @@ standard_name = tendency_of_cloud_condensation_nuclei_number_concentration_due_to_model_physics long_name = number concentration of cloud condensation nuclei tendency due to model physics units = kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 6e48363f4..6643b5356 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -391,7 +391,7 @@ standard_name = geopotential_at_interface long_name = geopotential at model layer interfaces units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + dimensions = (horizontal_loop_extent,vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -632,4 +632,3 @@ dimensions = () type = integer intent = out - From 59885eafbf8a19c69661f576311c7b6da65eafc3 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 31 Jan 2022 16:00:30 -0700 Subject: [PATCH 062/217] change dimensions of flag_convective_tracer_transport_interstitial to match allocation --- physics/GFS_suite_interstitial.meta | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 6d45ecad6..1b710b8b5 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1044,7 +1044,7 @@ standard_name = flag_convective_tracer_transport_interstitial long_name = flag for interstitial tracer transport units = flag - dimensions = (number_of_tracers_plus_one) + dimensions = (number_of_tracers) type = logical intent = in [im] @@ -1854,7 +1854,7 @@ standard_name = flag_convective_tracer_transport_interstitial long_name = flag for interstitial tracer transport units = flag - dimensions = (number_of_tracers_plus_one) + dimensions = (number_of_tracers) type = logical intent = in [errmsg] From 512ece1dee575f3ceec3cb1a4ed58b9bd513045b Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Tue, 1 Feb 2022 04:14:17 +0000 Subject: [PATCH 063/217] Output canopy resistance and leaf area index from Noah LSM driver. --- physics/sfc_drv.f | 12 +++++++++--- physics/sfc_drv.meta | 16 ++++++++++++++++ 2 files changed, 25 insertions(+), 3 deletions(-) diff --git a/physics/sfc_drv.f b/physics/sfc_drv.f index 817897fe7..e61d3be5e 100644 --- a/physics/sfc_drv.f +++ b/physics/sfc_drv.f @@ -196,6 +196,8 @@ end subroutine lsm_noah_finalize ! smcwlt2 - real, dry soil moisture threshold im ! ! smcref2 - real, soil moisture threshold im ! ! wet1 - real, normalized soil wetness im ! +! lai - real, leaf area index (dimensionless) im ! +! rca - real, canopy resistance (s/m) im ! ! ! ! ==================== end of description ===================== ! @@ -225,7 +227,7 @@ subroutine lsm_noah_run & ! --- outputs: & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & - & smcwlt2, smcref2, wet1, errmsg, errflg & + & smcwlt2, smcref2, wet1, lai, rca, errmsg, errflg & & ) ! !use machine , only : kind_phys @@ -282,7 +284,7 @@ subroutine lsm_noah_run & real (kind=kind_phys), dimension(:), intent(inout) :: sncovr1, & & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2, & - & wet1 + & wet1, lai, rca character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -552,6 +554,8 @@ subroutine lsm_noah_run & !!\n ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) !!\n runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface !!\n runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom +!!\n xlai - leaf area index (dimensionless) +!!\n rca - canopy resistance (s/m) evap(i) = eta hflx(i) = sheat @@ -590,6 +594,9 @@ subroutine lsm_noah_run & ! ---- ... outside sflx, roughness uses cm as unit (update after snow's effect) zorl(i) = z0*100.0_kind_phys + lai(i) = xlai + rca(i) = rc + !> - Do not return the following output fields to parent model: !!\n ec - canopy water evaporation (m s-1) !!\n edir - direct soil evaporation (m s-1) @@ -610,7 +617,6 @@ subroutine lsm_noah_run & !!\n rc - canopy resistance (s m-1) !!\n pc - plant coefficient (unitless fraction, 0-1) where pc*etp !! = actual transp -!!\n xlai - leaf area index (dimensionless) !!\n rsmin - minimum canopy resistance (s m-1) !!\n rcs - incoming solar rc factor (dimensionless) !!\n rct - air temperature rc factor (dimensionless) diff --git a/physics/sfc_drv.meta b/physics/sfc_drv.meta index a3aa9044e..2ce7c3e6c 100644 --- a/physics/sfc_drv.meta +++ b/physics/sfc_drv.meta @@ -734,6 +734,22 @@ type = real kind = kind_phys intent = inout +[lai] + standard_name = leaf_area_index + long_name = leaf area index + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[rca] + standard_name = aerodynamic_resistance_in_canopy + long_name = canopy resistance + units = s m-1 + 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 From f1d49d163ec53fee3ec8757cc159099dd5509d5f Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Tue, 1 Feb 2022 13:59:02 -0600 Subject: [PATCH 064/217] Tweaks to snow aggregation (slight reduction to help reduce excess reflectivity) --- physics/module_mp_nssl_2mom.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 7131739c0..af19a0131 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -417,10 +417,10 @@ MODULE module_mp_nssl_2mom real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! set ehs1 = 0 to get a constant value of ehs0 - real , private :: ess0 = 1.0, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) + real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) ! set ess1 = 0 to get a constant value of ess0 - real , private :: esstem1 = -25. ! lower temperature where snow aggregation turns on - real , private :: esstem2 = -20. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on + real , private :: esstem2 = -10. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 real , private :: essrmax = 0.02 ! maximum snow radius (meters) for csacs real , private :: essfrac1 = 0.5 ! snow mass fraction 1 for aggregation roll-off real , private :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off From 1cd31f921668dce4ff6406176532dabf465e04c5 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 11 Feb 2022 18:48:29 +0000 Subject: [PATCH 065/217] Reduced dtpmax to 60 to maintain stability based on new tests --- physics/mp_nssl.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index cf1a4b8fa..6d1c16420 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -285,7 +285,7 @@ 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 = 150. ! 300. ! 600. ! 120. + real, parameter :: dtpmax = 60. ! allow up to dt=75 (1.25*60) real(kind_phys) :: dtptmp integer, parameter :: ndebug = 0 logical :: invertccn @@ -480,8 +480,8 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & IF ( ndebug >= 1 ) write(0,*) 'call nssl_2mom_driver' - IF ( dtp > 1.5*dtpmax ) THEN - ntmul = Nint( dtp/dtpmax ) + IF ( dtp > 1.25001*dtpmax ) THEN + ntmul = Max(2, Nint( dtp/dtpmax ) ) dtptmp = dtp/ntmul ELSE dtptmp = dtp From 2c02bc58075828c1d72c5da66f7cdedccc2f38cb Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sat, 12 Feb 2022 19:13:28 -0600 Subject: [PATCH 066/217] Reduce potential sedimentation computation with interval_sedi_vt=2 --- physics/module_mp_nssl_2mom.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index af19a0131..fde15fac5 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -261,7 +261,7 @@ MODULE module_mp_nssl_2mom logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive) ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) ! Mainly is an issue for small dz near the surface. - integer, private :: interval_sedi_vt = 1 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.) + integer, private :: interval_sedi_vt = 2 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.) integer, private :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) ! 1 -> uses mass-weighted fallspeed for N ALWAYS ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS) @@ -1251,7 +1251,7 @@ SUBROUTINE nssl_2mom_init( & IF ( present ( myrank ) .and. present ( mpiroot ) ) THEN IF ( myrank == mpiroot ) THEN IF ( istat /= 0 ) THEN - write(0,*) 'READ_NAMELIST: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' ENDIF ! write(0,*) 'iusewetsnow = ',iusewetsnow From 0ea0fd03743e674bcd8109caa4784eaf8d10362f Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Mon, 14 Feb 2022 17:39:55 +0000 Subject: [PATCH 067/217] Code update for radiation_clouds.f and GFS_rrtmg_pre.F90 GFS_cloud_diagnostics.F90 and related meta files --- physics/GFS_cloud_diagnostics.F90 | 13 +- physics/GFS_cloud_diagnostics.meta | 42 + physics/GFS_rrtmg_pre.F90 | 206 +--- physics/GFS_rrtmg_pre.meta | 63 + physics/radiation_clouds.f | 1821 ++++++++++++---------------- 5 files changed, 942 insertions(+), 1203 deletions(-) diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/GFS_cloud_diagnostics.F90 index 215143bb2..214d12bbd 100644 --- a/physics/GFS_cloud_diagnostics.F90 +++ b/physics/GFS_cloud_diagnostics.F90 @@ -39,7 +39,8 @@ end subroutine GFS_cloud_diagnostics_init !! \section arg_table_GFS_cloud_diagnostics_run !! \htmlinclude GFS_cloud_diagnostics_run.html !! - subroutine GFS_cloud_diagnostics_run(nCol, nLev, lsswr, lslwr, lat, de_lgth, p_lay, & + subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_max, & + iovr_dcorr, iovr_exp, iovr_exprand, lsswr, lslwr, lat, de_lgth, p_lay, & cld_frac, p_lev, deltaZ, cloud_overlap_param, precip_overlap_param, con_pi, & mtopa, mbota, cldsa, errmsg, errflg) implicit none @@ -48,6 +49,13 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, lsswr, lslwr, lat, de_lgth, p_l integer, intent(in) :: & nCol, & ! Number of horizontal grid-points nLev ! Number of vertical-layers + integer, intent(in) :: & + iovr_rand, & ! Flag for random cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_max, & ! Flag for maximum cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand ! Flag for exponential-random cloud overlap method logical, intent(in) :: & lsswr, & ! Call SW radiation? lslwr ! Call LW radiation @@ -106,7 +114,8 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, lsswr, lslwr, lat, de_lgth, p_l ! defined by ptopc. The cloud overlapping method is defined by control flag 'iovr', which may ! be different for lw and sw radiation programs. call gethml(p_lay/100., ptop1, cld_frac, cldcnv, deltaZ, de_lgth, cloud_overlap_param,& - nCol, nLev, cldsa, mtopa, mbota) + nCol, nLev, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & + iovr_exprand, cldsa, mtopa, mbota) end subroutine GFS_cloud_diagnostics_run diff --git a/physics/GFS_cloud_diagnostics.meta b/physics/GFS_cloud_diagnostics.meta index aab5387d0..dd88bbc46 100644 --- a/physics/GFS_cloud_diagnostics.meta +++ b/physics/GFS_cloud_diagnostics.meta @@ -20,6 +20,48 @@ dimensions = () type = integer intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in [lsswr] standard_name = flag_for_calling_shortwave_radiation long_name = logical flags for sw radiation calls diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 7e7d9750b..c69ad7286 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -22,7 +22,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & - imp_physics_fer_hires, julian, yearlen, lndp_var_list, lsswr, lslwr, & + imp_physics_fer_hires, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & + iovr_exp, iovr_exprand, idcor_con, idcor_hogan, idcor_oreopoulos, & + julian, yearlen, lndp_var_list, lsswr, lslwr, & ltaerosol, lgfdlmprad, uni_cld, effr_in, do_mynnedmf, lmfshal, & lmfdeep2, fhswr, fhlwr, solhr, sup, con_eps, epsm1, fvirt, & rog, rocp, con_rd, xlat_d, xlat, xlon, coslat, sinlat, tsfc, slmsk, & @@ -51,12 +53,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & use module_radiation_aerosols, only: NF_AESW, NF_AELW, setaer, & ! aer_init, aer_update, & NSPC1 use module_radiation_clouds, only: NF_CLDS, & ! cld_init - & progcld1, progcld3, & - & progcld2, & - & progcld4, progcld5, & - & progcld6, & - & progcld_thompson, & - & progclduni, & + & radiation_clouds_prop, & & cal_cldfra3, & & find_cloudLayers, & & adjust_cloudIce, & @@ -98,6 +95,17 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imp_physics_fer_hires, & yearlen, icloud + integer, intent(in) :: & + iovr_rand, & ! Flag for random cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_max, & ! Flag for maximum cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand, & ! Flag for exponential-random cloud overlap method + idcor_con, & + idcor_hogan, & + idcor_oreopoulos + character(len=3), dimension(:), intent(in) :: lndp_var_list logical, intent(in) :: lsswr, lslwr, ltaerosol, lgfdlmprad, & @@ -206,7 +214,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(im,lm+LTP,min(4,ncnd)) :: ccnd real(kind=kind_phys), dimension(im,lm+LTP,2:ntrac) :: tracer1 - real(kind=kind_phys), dimension(im,lm+LTP,NF_CLDS) :: clouds + real(kind=kind_phys), dimension(im,lm+LTP) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow real(kind=kind_phys), dimension(im,lm+LTP,NF_VGAS) :: gasvmr real(kind=kind_phys), dimension(im,lm+LTP,NBDSW,NF_AESW) :: faersw real(kind=kind_phys), dimension(im,lm+LTP,NBDLW,NF_AELW) :: faerlw @@ -613,9 +623,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & !! (clouds,cldsa,mtopa,mbota) !!\n for prognostic cloud: !! - For Zhao/Moorthi's prognostic cloud scheme, -!! call module_radiation_clouds::progcld1() +!! call module_radiation_clouds::progcld_zhao_carr() !! - For Zhao/Moorthi's prognostic cloud+pdfcld, -!! call module_radiation_clouds::progcld3() +!! call module_radiation_clouds::progcld_zhao_carr_pdf() !! call module_radiation_clouds::progclduni() for unified cloud and ncnd>=2 ! --- ... obtain cloud information for radiation calculations @@ -882,135 +892,29 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ccnd(1:IM,1:LMK,1) = ccnd(1:IM,1:LMK,1) + cnvw(1:IM,1:LMK) endif - if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_mg) then ! zhao/moorthi's prognostic cloud scheme - ! or unified cloud and/or with MG microphysics - - if (uni_cld .and. ncndl >= 2) then - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs - xlat, xlon, slmsk, dz, delp, & - IM, LMK, LMP, cldcov, & - effrl, effri, effrr, effrs, effr_in, & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - else - call progcld1 (plyr ,plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - ccnd(1:IM,1:LMK,1), xlat, xlon, slmsk, dz, & - delp, IM, LMK, LMP, uni_cld, lmfshal, lmfdeep2,& - cldcov, effrl, effri, effrr, effrs, effr_in, & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - endif - - elseif(imp_physics == imp_physics_zhao_carr_pdf) then ! zhao/moorthi's prognostic cloud+pdfcld - - call progcld3 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - ccnd(1:IM,1:LMK,1), cnvw, cnvc, xlat, xlon, & - slmsk, dz, delp, im, lmk, lmp, deltaq, sup, kdt, & - me, dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - - elseif (imp_physics == imp_physics_gfdl) then ! GFDL cloud scheme - - if (.not. lgfdlmprad) then - call progcld4 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - ccnd(1:IM,1:LMK,1), cnvw, cnvc, xlat, xlon, & - slmsk, cldcov, dz, delp, im, lmk, lmp, & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - else - - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, xlat, & ! --- inputs - xlon, slmsk, dz,delp, IM, LMK, LMP, cldcov, & - effrl, effri, effrr, effrs, effr_in, & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs -! call progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs -! tracer1, xlat, xlon, slmsk, dz, delp, & -! ntrac-1, ntcw-1,ntiw-1,ntrw-1, & -! ntsw-1,ntgl-1,ntclamt-1, & -! im, lmk, lmp, & -! dzb, xlat_d, julian, yearlen, & -! clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - endif - - elseif(imp_physics == imp_physics_fer_hires) then - if (kdt == 1) then - effrl_inout(:,:) = 10. - effri_inout(:,:) = 50. - effrs_inout(:,:) = 250. - endif - - call progcld5 (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,tracer1, & ! --- inputs - xlat,xlon,slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - im, lmk, lmp, icloud, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LMK),effrl_inout(:,:), & - effri_inout(:,:), effrs_inout(:,:), & - dzb, xlat_d, julian, yearlen, & - clouds,cldsa,mtopa,mbota, de_lgth, alpha) ! --- outputs - - elseif(imp_physics == imp_physics_thompson) then ! Thompson MP - - if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv - - if (icloud == 3) then - call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs - tracer1,xlat,xlon,slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - ntsw-1,ntgl-1, & - im, lm, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LM), effrl, effri, effrs, & - lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - dzb, xlat_d, julian, yearlen, gridkm, & - clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs - else - - !-- MYNN PBL or convective GF - !-- use cloud fractions with SGS clouds - do k=1,lmk - do i=1,im - clouds(i,k,1) = clouds1(i,k) - enddo - enddo - - ! --- use clduni as with the GFDL microphysics. - ! --- make sure that effr_in=.true. in the input.nml! - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs - xlat, xlon, slmsk, dz, delp, IM, LMK, LMP, & - clouds(:,1:LMK,1), & - effrl, effri, effrr, effrs, effr_in , & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - endif - - else - ! MYNN PBL or GF convective are not used - - if (icloud == 3) then - call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs - tracer1,xlat,xlon,slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - ntsw-1,ntgl-1, & - im, lm, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LM), effrl, effri, effrs, & - lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - dzb, xlat_d, julian, yearlen, gridkm, & - clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs - - else - call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs - tracer1,xlat,xlon,slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - ntsw-1,ntgl-1, & - im, lmk, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LMK), cnvw, effrl, effri, effrs,& - lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs - endif - endif ! MYNN PBL or GF + call radiation_clouds_prop & + & ( plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs: + & ccnd, ncndl, cnvw, cnvc, tracer1, & + & xlat, xlon, slmsk, dz, delp, IM, LM, LMK, LMP, & + & deltaq, sup, me, icloud, kdt, & + & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & + & imp_physics, imp_physics_fer_hires,imp_physics_gfdl, & + & imp_physics_thompson, imp_physics_wsm6, & + & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & + & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & + & idcor_hogan, idcor_oreopoulos, & + & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & + & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & + & effrl, effri, effrr, effrs, effr_in, & + & effrl_inout, effri_inout, effrs_inout, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzb, xlat_d, julian, yearlen, gridkm, & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & ! --- outputs: + & cld_rwp, cld_rerain, cld_swp, cld_resnow, & ! --- outputs: + & cldsa, mtopa, mbota, de_lgth, alpha & ! --- outputs: + & ) - endif ! end if_imp_physics ! endif ! end_if_ntcw @@ -1024,7 +928,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & do k = 1, LMK do i = 1, IM ! compute beta distribution parameters - m = clouds(i,k,1) + m = cld_frac(i,k) if (m<0.99 .AND. m > 0.01) then s = sppt_amp*m*(1.-m) alpha0 = m*m*(1.-m)/(s*s)-m @@ -1032,25 +936,25 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ! compute beta distribution value corresponding ! to the given percentile albPpert to use as new albedo call ppfbet(cldp1d(i),alpha0,beta0,iflag,cldtmp) - clouds(i,k,1) = cldtmp + cld_frac(i,k) = cldtmp else - clouds(i,k,1) = m + cld_frac(i,k) = m endif enddo ! end_do_i_loop enddo ! end_do_k_loop endif do k = 1, LM do i = 1, IM - clouds1(i,k) = clouds(i,k,1) - clouds2(i,k) = clouds(i,k,2) - clouds3(i,k) = clouds(i,k,3) - clouds4(i,k) = clouds(i,k,4) - clouds5(i,k) = clouds(i,k,5) - clouds6(i,k) = clouds(i,k,6) - clouds7(i,k) = clouds(i,k,7) - clouds8(i,k) = clouds(i,k,8) - clouds9(i,k) = clouds(i,k,9) - cldfra(i,k) = clouds(i,k,1) + clouds1(i,k) = cld_frac(i,k) + clouds2(i,k) = cld_lwp(i,k) + clouds3(i,k) = cld_reliq(i,k) + clouds4(i,k) = cld_iwp(i,k) + clouds5(i,k) = cld_reice(i,k) + clouds6(i,k) = cld_rwp(i,k) + clouds7(i,k) = cld_rerain(i,k) + clouds8(i,k) = cld_swp(i,k) + clouds9(i,k) = cld_resnow(i,k) + cldfra(i,k) = cld_frac(i,k) enddo enddo do i = 1, IM diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 48fc31c49..1983e8078 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -275,6 +275,69 @@ dimensions = () type = integer intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[idcor_con] + standard_name = flag_for_constant_decorrelation_length_method + long_name = choice of decorrelation length computation (costant) + units = flag + dimensions = () + type = integer + intent = in +[idcor_hogan] + standard_name = flag_for_hogan_decorrelation_length_method + long_name = choice of decorrelation length computation (hogan) + units = flag + dimensions = () + type = integer + intent = in +[idcor_oreopoulos] + standard_name = flag_for_oreopoulos_decorrelation_length_method + long_name = choice of decorrelation length computation (oreopoulos) + units = flag + dimensions = () + type = integer + intent = in [julian] standard_name = forecast_julian_day long_name = julian day diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index c3e0b1293..157350dff 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -18,82 +18,55 @@ ! outputs: ! ! ( none ) ! ! ! -! 'progcld1' --- zhao/moorthi prognostic cloud scheme ! +! 'radiation_clouds_prop' --- radiation cloud properties ! +! obtained from various cloud schemes ! ! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, ! -! xlat,xlon,slmsk,dz,delp, ! -! IX, NLAY, NLP1, ! -! uni_cld, lmfshal, lmfdeep2, cldcov, ! -! effrl,effri,effrr,effrs,effr_in, ! -! dzlay, latdeg, julian, yearlen, ! +! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly, ! +! ccnd, ncndl, cnvw, cnvc, tracer1, ! +! xlat,xlon,slmsk,dz,delp, IX, LM, NLAY, NLP1, ! +! deltaq, sup, me, icloud, kdt, ! +! ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, ! +! imp_physics, imp_physics_fer_hires,imp_physics_gfdl, ! +! imp_physics_thompson, imp_physics_wsm6, ! +! imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, ! +! imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, ! +! iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, ! +! idcor_hogan, idcor_oreopoulos, ! +! imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, ! +! uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, ! +! effrl, effri, effrr, effrs, effr_in, ! +! effrl_inout, effri_inout, effrs_inout, ! +! lwp_ex, iwp_ex, lwp_fc, iwp_fc, ! +! dzlay, latdeg, julian, yearlen, gridkm, ! ! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! +! cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, ! +! cld_rwp, cld_rerain, cld_swp, cld_resnow, ! +! clds,mtop,mbot,de_lgth,alpha) ! ! ! -! 'progcld2' --- ferrier prognostic cloud microphysics ! -! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, ! -! xlat,xlon,slmsk,dz,delp, f_ice,f_rain,r_rime,flgmin, ! -! IX, NLAY, NLP1, lmfshal, lmfdeep2, ! -! dzlay, latdeg, julian, yearlen, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! -! ! -! 'progcld3' --- zhao/moorthi prognostic cloud + pdfcld! -! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, ! -! xlat,xlon,slmsk, dz, delp, ! -! ix, nlay, nlp1, ! -! deltaq,sup,kdt,me, ! -! dzlay, latdeg, julian, yearlen, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! -! ! -! 'progcld4' --- gfdl-lin cloud microphysics ! -! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, ! -! xlat,xlon,slmsk, dz, delp, ! -! ix, nlay, nlp1, ! -! dzlay, latdeg, julian, yearlen, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! -! ! -! 'progcld4o' --- inactive ! -! ! -! 'progcld5' --- wsm6 cloud microphysics ! -! inputs: ! -! (plyr,plvl,tlyr,qlyr,qstl,rhly,clw, ! -! xlat,xlon,slmsk, dz, delp, ! -! ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, ! -! ix, nlay, nlp1, ! -! uni_cld, lmfshal, lmfdeep2, cldcov, ! -! re_cloud,re_ice,re_snow, ! -! dzlay, latdeg, julian, yearlen, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! -! ! -! 'progclduni' --- for unified clouds with MG microphys! -! inputs: ! -! (plyr,plvl,tlyr,tvly,ccnd,ncnd, ! -! xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, ! -! effrl,effri,effrr,effrs,effr_in, ! -! dzlay, latdeg, julian, yearlen, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! +! internal/external accessable subroutines: ! +! 'progcld_zhao_carr' --- zhao/moorthi prognostic cloud scheme ! +! 'progcld2' --- inactive ! +! 'progcld_zhao_carr_pdf' --- zhao/moorthi prognostic cloud + pdfcld ! +! 'progcld_gfdl_lin' --- GFDL-Lin cloud microphysics ! +! 'progcld4o' --- inactive ! +! 'progcld_fer_hires' --- Ferrier-Aligo cloud microphysics ! +! 'progcld_thompson_wsm6' --- Thompson/wsm6 cloud microphysics (EMC) ! +! 'progclduni' --- MG cloud microphysics ! +! --- GFDL cloud microphysics (EMC) ! +! --- Thompson + MYNN PBL (or GF convection) ! +! 'progcld_thompson' --- Thompson MP (added by G. Thompson) ! +! 'gethml' --- get diagnostic hi, mid, low clouds ! ! ! -! internal accessable only subroutines: ! -! 'gethml' --- get diagnostic hi, mid, low clouds ! -! ! -! ! -! cloud array description: ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path ! -! clouds(:,:,3) - mean effective radius for liquid cloud ! -! clouds(:,:,4) - layer cloud ice water path ! -! clouds(:,:,5) - mean effective radius for ice cloud ! -! clouds(:,:,6) - layer rain drop water path ! -! clouds(:,:,7) - mean effective radius for rain drop ! -! ** clouds(:,:,8) - layer snow flake water path ! -! clouds(:,:,9) - mean effective radius for snow flake ! +! cloud property array description: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path ! +! cld_reliq (:,:) - mean effective radius for liquid cloud ! +! cld_iwp (:,:) - layer cloud ice water path ! +! cld_reice (:,:) - mean effective radius for ice cloud ! +! cld_rwp (:,:) - layer rain drop water path ! +! cld_rerain(:,:) - mean effective radius for rain drop ! +! ** cld_swp (:,:) - layer snow flake water path ! +! cld_resnow(:,:) - mean effective radius for snow flake ! ! ** fu's scheme need to be normalized by snow density (g/m**3/1.0e6)! ! ! ! external modules referenced: ! @@ -141,7 +114,7 @@ ! adjusted for better agreement with observations. ! ! jan 2011, yu-tai hou - changed virtual temperature ! ! as input variable instead of originally computed inside the ! -! two prognostic cld schemes 'progcld1' and 'progcld2'. ! +! two prognostic cld schemes 'progcld_zhao_carr' and 'progcld2'. ! ! aug 2012, yu-tai hou - modified subroutine cld_init ! ! to pass all fixed control variables at the start. and set ! ! their correponding internal module variables to be used by ! @@ -165,6 +138,9 @@ ! either a constant or a latitude-varying and day-of-year ! ! varying decorrelation length selected with parameter "idcor". ! ! ! +! Jan 2022, Q.Liu - add subroutine radiation_clouds_prop, and ! +! move all the subroutine call "progcld*" from ! +! GFS_rrtmg_pre.F90 to this new subroutine ! !!!!! ========================================================== !!!!! !!!!! end descriptions !!!!! !!!!! ========================================================== !!!!! @@ -277,9 +253,10 @@ module module_radiation_clouds & 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & & 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/) - public progcld1, progcld2, progcld3, progcld4, progclduni, & - & cld_init, progcld5, progcld4o, & - & progcld6, progcld_thompson, cal_cldfra3, & + public progcld_zhao_carr, progcld2, progcld_zhao_carr_pdf, & + & progcld_gfdl_lin, progclduni, progcld_fer_hires, & + & cld_init, radiation_clouds_prop, progcld4o, & + & progcld_thompson_wsm6, progcld_thompson, cal_cldfra3, & & find_cloudLayers, adjust_cloudIce, adjust_cloudH2O, & & adjust_cloudFinal, gethml @@ -426,8 +403,8 @@ end subroutine cld_init !----------------------------------- !> \ingroup module_radiation_clouds -!> This subroutine computes cloud related quantities using -!! zhao/moorthi's prognostic cloud microphysics scheme. +!> Subroutine radiation_clouds_prop computes cloud related quantities +!! for different cloud microphysics schemes. !!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) !!\param plvl (IX,NLP1), model level pressure in mb (100Pa) !!\param tlyr (IX,NLAY), model layer mean temperature in K @@ -435,58 +412,119 @@ end subroutine cld_init !!\param qlyr (IX,NLAY), layer specific humidity in gm/gm !!\param qstl (IX,NLAY), layer saturate humidity in gm/gm !!\param rhly (IX,NLAY), layer relative humidity \f$ (=qlyr/qstl) \f$ -!!\param clw (IX,NLAY), layer cloud condensate amount +!!\param ccnd (IX,NLAY,ncndl), layer cloud condensate amount ! +!! water, ice, rain, snow (+ graupel) ! +!!\param ncndl number of layer cloud condensate types (max of 4) +!!\param cnvw (ix,nlay), layer convective cloud condensate +!!\param cnvc (ix,nlay), layer convective cloud cover +!!\param tracer1 (ix,nlay,1:ntrac-1), all tracers (except sphum) !!\param xlat (IX), grid latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment +!! -pi/2 range, otherwise see in-line comment !!\param xlon (IX), grid longitude in radians (not used) !!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) -!!\param dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) +!!\param dz (IX,NLAY), layer thickness (km) +!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) !!\param IX horizontal dimention -!!\param NLAY vertical layer +!!\param LM vertical layer for radiation calculation +!!\param NLAY adjusted vertical layer !!\param NLP1 level dimensions +!!\param deltaq (ix,nlay), half total water distribution width +!!\param sup supersaturation +!!\param me print control flag +!!\param icloud cloud effect to the optical depth in radiation +!!\param kdt current time step index +!>\param ntrac number of tracers (Model%ntrac) +!>\param ntcw tracer index for cloud liquid water (Model%ntcw) +!>\param ntiw tracer index for cloud ice water (Model%ntiw) +!>\param ntrw tracer index for rain water (Model%ntrw) +!>\param ntsw tracer index for snow water (Model%ntsw) +!>\param ntgl tracer index for graupel (Model%ntgl) +!>\param ntclamt tracer index for cloud amount (Model%ntclamt) +!!\param imp_physics cloud microphysics scheme control flag +!!\param imp_physics_fer_hires Ferrier-Aligo microphysics (=15) +!!\param imp_physics_gfdl GFDL microphysics cloud (=11) +!!\param imp_physics_thompson Thompson microphysics (=8) +!!\param imp_physics_wsm6 WSM6 microphysics (=6) +!!\param imp_physics_zhao_carr Zhao-Carr/Sundqvist microphysics cloud (=99) +!!\param imp_physics_zhao_carr_pdf Zhao-Carr/Sundqvist microphysics cloud + PDF (=98) +!!\param imp_physics_mg MG microphysics (=10) +!!\param iovr_rand cloud-overlap: random +!!\param iovr_maxrand cloud-overlap: maximum random +!!\param iovr_max cloud-overlap: maximum +!!\param iovr_dcorr cloud-overlap: decorrelation length +!!\param iovr_exp cloud-overlap: exponential +!!\param iovr_exprand cloud-overlap: exponential random +!!\param idcor_con decorrelation-length: Use constant value +!!\param idcor_hogan choice for decorrelation-length +!!\param idcor_oreopoulos choice for decorrelation-length +!!\param imfdeepcnv flag for mass-flux deep convection scheme +!!\param imfdeepcnv_gf flag for scale- & aerosol-aware Grell-Freitas scheme (GSD) +!!\param do_mynnedmf flag for MYNN-EDMF +!!\param lgfdlmprad flag for GFDLMP radiation interaction !!\param uni_cld logical, true for cloud fraction from shoc !!\param lmfshal logical, mass-flux shallow convection scheme flag !!\param lmfdeep2 logical, scale-aware mass-flux deep convection scheme flag !!\param cldcov layer cloud fraction (used when uni_cld=.true.) +!!\param clouds1 layer total cloud fraction !!\param effrl effective radius for liquid water !!\param effri effective radius for ice water !!\param effrr effective radius for rain water !!\param effrs effective radius for snow water !!\param effr_in logical, if .true. use input effective radii -!!\param dzlay(ix,nlay) distance between model layer centers +!!\param effrl_inout eff. radius of cloud liquid water particle +!!\param effri_inout eff. radius of cloud ice water particle +!!\param effrs_inout effective radius of cloud snow particle +!!\param lwp_ex total liquid water path from explicit microphysics +!!\param iwp_ex total ice water path from explicit microphysics +!!\param lwp_fc total liquid water path from cloud fraction scheme +!!\param iwp_fc total ice water path from cloud fraction scheme +!!\param dzlay(ix,nlay) distance between model layer centers !!\param latdeg(ix) latitude (in degrees 90 -> -90) !!\param julian day of the year (fractional julian day) !!\param yearlen current length of the year (365/366 days) -!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles -!!\n (:,:,1) - layer total cloud fraction -!!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ -!!\n (:,:,3) - mean eff radius for liq cloud (micron) -!!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ -!!\n (:,:,5) - mean eff radius for ice cloud (micron) -!!\n (:,:,6) - layer rain drop water path (not assigned) -!!\n (:,:,7) - mean eff radius for rain drop (micron) -!!\n (:,:,8) - layer snow flake water path (not assigned) -!!\n (:,:,9) - mean eff radius for snow flake (micron) +!!\param gridkm grid length in km +!!\param cld_frac(:,:) - layer total cloud fraction +!!\param cld_lwp(:,:) - layer cloud liq water path \f$(g/m^2)\f$ +!!\param cld_reliq(:,:) - mean eff radius for liq cloud (micron) +!!\param cld_iwp(:,:) - layer cloud ice water path \f$(g/m^2)\f$ +!!\param cld_reice(:,:) - mean eff radius for ice cloud (micron) +!!\param cld_rwp(:,:) - layer rain drop water path (not assigned) +!!\param cld_rerain(:,:) - mean eff radius for rain drop (micron) +!!\param cld_swp(:,:) - layer snow flake water path (not assigned) +!!\param cld_resnow(:,:) - mean eff radius for snow flake (micron) !!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl !!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops !!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases !!\param de_lgth (IX), clouds decorrelation length (km) !!\param alpha (IX,NLAY), alpha decorrelation parameter -!>\section gen_progcld1 progcld1 General Algorithm +!>\section gen_radiation_clouds_prop radiation_clouds_prop General Algorithm !> @{ - subroutine progcld1 & - & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, & - & uni_cld, lmfshal, lmfdeep2, cldcov, & - & effrl,effri,effrr,effrs,effr_in, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + subroutine radiation_clouds_prop & + & ( plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs: + & ccnd, ncndl, cnvw, cnvc, tracer1, & + & xlat, xlon, slmsk, dz, delp, IX, LM, NLAY, NLP1, & + & deltaq, sup, me, icloud, kdt, & + & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & + & imp_physics, imp_physics_fer_hires,imp_physics_gfdl, & + & imp_physics_thompson, imp_physics_wsm6, & + & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & + & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & + & idcor_hogan, idcor_oreopoulos, & + & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & + & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & + & effrl, effri, effrr, effrs, effr_in, & + & effrl_inout, effri_inout, effrs_inout, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzlay, latdeg, julian, yearlen, gridkm, & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & ! --- outputs: + & cld_rwp, cld_rerain, cld_swp, cld_resnow, & + & clds, mtop, mbot, de_lgth, alpha & & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld1 computes cloud related quantities using ! +! subprogram: radiation_clouds_prop computes cloud related quantities using ! ! zhao/moorthi's prognostic cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! @@ -494,12 +532,23 @@ subroutine progcld1 & ! and computes the low, mid, high, total and boundary layer cloud ! ! fractions and the vertical indices of low, mid, and high cloud ! ! top and base. the three vertical cloud domains are set up in the ! -! initial subroutine "cld_init". ! +! initial subroutine "radiation_clouds_init". ! ! ! -! usage: call progcld1 ! +! usage: call radiation_clouds_prop ! ! ! -! subprograms called: gethml ! +! subprograms called: ! ! ! +! 'progcld_zhao_carr' --- zhao/moorthi prognostic cloud scheme ! +! 'progcld2' --- inactive ! +! 'progcld_zhao_carr_pdf' --- zhao/moorthi prognostic cloud + pdfcld ! +! 'progcld_gfdl_lin' --- GFDL-Lin cloud microphysics ! +! 'progcld4o' --- inactive ! +! 'progcld_fer_hires' --- Ferrier-Aligo cloud microphysics ! +! 'progcld_thompson_wsm6' --- Thompson/wsm6 cloud microphysics (EMC) ! +! 'progclduni' --- MG cloud microphysics ! +! --- GFDL cloud microphysics (EMC) ! +! --- Thompson + MYNN PBL (or GF convection) ! +! 'progcld_thompson' --- Thompson MP (added by G. Thompson) ! ! attributes: ! ! language: fortran 90 ! ! machine: ibm-sp, sgi ! @@ -515,7 +564,12 @@ subroutine progcld1 & ! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! ! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! ! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! -! clw (IX,NLAY) : layer cloud condensate amount ! +! ccnd (IX,NLAY,ncndl) : layer cloud condensate amount ! +! water, ice, rain, snow (+ graupel) ! +! ncndl : number of layer cloud condensate types (max of 4) ! +! cnvw (IX,NLAY) : layer convective cloud condensate ! +! cnvc (IX,NLAY) : layer convective cloud cover ! +! tracer1 (IX,NLAY,1:ntrac-1) : all tracers (except sphum) ! ! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! ! range, otherwise see in-line comment ! ! xlon (IX) : grid longitude in radians (not used) ! @@ -523,27 +577,74 @@ subroutine progcld1 & ! dz (ix,nlay) : layer thickness (km) ! ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! ! IX : horizontal dimention ! -! NLAY,NLP1 : vertical layer/level dimensions ! +! LM,NLAY,NLP1 : vertical layer/level dimensions ! +! deltaq (ix,nlay), half total water distribution width ! +! sup supersaturation ! +! me print control flag ! +! icloud : cloud effect to the optical depth in radiation ! +! kdt : current time step index ! +! ntrac number of tracers (Model%ntrac) ! +! ntcw tracer index for cloud liquid water (Model%ntcw) ! +! ntiw tracer index for cloud ice water (Model%ntiw) ! +! ntrw tracer index for rain water (Model%ntrw) ! +! ntsw tracer index for snow water (Model%ntsw) ! +! ntgl tracer index for graupel (Model%ntgl) ! +! ntclamt tracer index for cloud amount (Model%ntclamt) ! +! imp_physics : cloud microphysics scheme control flag ! +! imp_physics_fer_hires : Ferrier-Aligo microphysics scheme ! +! imp_physics_gfdl : GFDL microphysics scheme ! +! imp_physics_thompson : Thompson microphysics scheme ! +! imp_physics_wsm6 : WSMG microphysics scheme ! +! imp_physics_zhao_carr : Zhao-Carr microphysics scheme ! +! imp_physics_zhao_carr_pdf : Zhao-Carr microphysics scheme with PDF clouds +! imp_physics_mg : Morrison-Gettelman microphysics scheme ! +! iovr_rand : choice of cloud-overlap: random (=0) +! iovr_maxrand : choice of cloud-overlap: maximum random (=1) +! iovr_max : choice of cloud-overlap: maximum (=2) +! iovr_dcorr : choice of cloud-overlap: decorrelation length (=3) +! iovr_exp : choice of cloud-overlap: exponential (=4) +! iovr_exprand : choice of cloud-overlap: exponential random (=5) +! idcor_con : choice for decorrelation-length: Use constant value (=0) +! idcor_hogan : choice for decorrelation-length: (=1) +! idcor_oreopoulos: choice for decorrelation-length: (=2) +! imfdeepcnv : flag for mass-flux deep convection scheme ! +! imfdeepcnv_gf : flag for scale- & aerosol-aware Grell-Freitas scheme (GSD) +! do_mynnedmf : flag for MYNN-EDMF ! +! lgfdlmprad : flag for GFDLMP radiation interaction ! ! uni_cld : logical - true for cloud fraction from shoc ! ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! clouds1 : layer total cloud fraction +! effrl, : effective radius for liquid water +! effri, : effective radius for ice water +! effrr, : effective radius for rain water +! effrs, : effective radius for snow water +! effr_in, : flag to use effective radii of cloud species in radiation +! effrl_inout, : eff. radius of cloud liquid water particle +! effri_inout, : eff. radius of cloud ice water particle +! effrs_inout : effective radius of cloud snow particle +! lwp_ex : total liquid water path from explicit microphysics +! iwp_ex : total ice water path from explicit microphysics +! lwp_fc : total liquid water path from cloud fraction scheme +! iwp_fc : total ice water path from cloud fraction scheme ! dzlay(ix,nlay) : thickness between model layer centers (km) ! ! latdeg(ix) : latitude (in degrees 90 -> -90) ! ! julian : day of the year (fractional julian day) ! ! yearlen : current length of the year (365/366 days) ! +! gridkm : grid length in km ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! ! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! @@ -563,30 +664,77 @@ subroutine progcld1 & ! lcnorm : control flag for in-cld condensate ! ! =t: normalize cloud condensate ! ! =f: not normalize cloud condensate ! +! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path not assigned ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! *** clouds(:,:,8) - layer snow flake water path not assigned ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! ! ! ! ==================== end of description ===================== ! -! implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 + integer, intent(in) :: IX, LM, NLAY, NLP1, me, ncndl, icloud + integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, & + & ntclamt + integer, intent(in) :: kdt, imfdeepcnv, imfdeepcnv_gf + integer, intent(in) :: & + & imp_physics, ! Flag for MP scheme + & imp_physics_fer_hires, ! Flag for fer-hires scheme + & imp_physics_gfdl, ! Flag for gfdl scheme + & imp_physics_thompson, ! Flag for thompsonscheme + & imp_physics_wsm6, ! Flag for wsm6 scheme + & imp_physics_zhao_carr, ! Flag for zhao-carr scheme + & imp_physics_zhao_carr_pdf, ! Flag for zhao-carr+PDF scheme + & imp_physics_mg ! Flag for MG scheme + + integer, intent(in) :: & + & iovr_rand, ! Flag for random cloud overlap method + & iovr_maxrand, ! Flag for maximum-random cloud overlap method + & iovr_max, ! Flag for maximum cloud overlap method + & iovr_dcorr, ! Flag for decorrelation-length cloud overlap method + & iovr_exp, ! Flag for exponential cloud overlap method + & iovr_exprand, ! Flag for exponential-random cloud overlap method + & idcor_con, + & idcor_hogan, + & idcor_oreopoulos + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in + logical, intent(in) :: do_mynnedmf, lgfdlmprad + real (kind=kind_phys), dimension(:,:,:), intent(in) :: ccnd, & + & tracer1 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, clw, cldcov, delp, dz, & - & effrl, effri, effrr, effrs, dzlay + & tlyr, tvly, qlyr, qstl, rhly, cnvw, cnvc, cldcov, & + & delp, dz, effrl, effri, effrr, effrs, dzlay, clouds1 + real (kind=kind_phys), intent(in) :: sup real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), dimension(:), intent(in) :: latdeg, gridkm real(kind=kind_phys), intent(in) :: julian integer, intent(in) :: yearlen +! --- inout + real(kind=kind_phys),dimension(:,:) :: deltaq + real(kind=kind_phys),dimension(:,:),intent(inout) :: & + & effrl_inout, effri_inout, effrs_inout + real(kind=kind_phys), dimension(:), intent(inout) :: & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc + ! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds +! real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + real (kind=kind_phys), dimension(:,:), intent(out) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow real (kind=kind_phys), dimension(:,:), intent(out) :: clds real (kind=kind_phys), dimension(:), intent(out) :: de_lgth real (kind=kind_phys), dimension(:,:), intent(out) :: alpha @@ -598,6 +746,7 @@ subroutine progcld1 & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) + real (kind=kind_phys), dimension(IX,NLAY,NF_CLDS) :: clouds real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 @@ -611,6 +760,11 @@ subroutine progcld1 & ! !===> ... begin here ! + if (me == 0 .and. kdt == 1) then & + print*, 'in radiation_clouds_prop=', imp_physics, uni_cld, & + & ncndl, lgfdlmprad, do_mynnedmf, imfdeepcnv, kdt + end if + do nf=1,nf_clds do k=1,nlay do i=1,ix @@ -618,8 +772,403 @@ subroutine progcld1 & enddo enddo enddo -! clouds(:,:,:) = 0.0 + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = 0.0 + cldcnv(i,k) = 0.0 + end do + end do + + if (imp_physics == imp_physics_zhao_carr .or. & + & imp_physics == imp_physics_mg) then ! zhao/moorthi's p + ! or unified cloud and/or with MG microphysics + + if (uni_cld .and. ncndl >= 2) then + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + & xlat, xlon, slmsk, dz, delp, & + & IX, NLAY, NLP1, cldcov, & + & effrl, effri, effrr, effrs, effr_in, & + & dzlay, & + & cldtot, cldcnv, & ! inout + & clouds) ! --- outputs + else + call progcld_zhao_carr (plyr ,plvl, tlyr, tvly, qlyr, & ! --- inputs + & qstl, rhly, ccnd(1:IX,1:NLAY,1), xlat, xlon, & + & slmsk, dz, delp, IX, NLAY, NLP1, uni_cld, & + & lmfshal, lmfdeep2, & + & cldcov, effrl, effri, effrr, effrs, effr_in, & + & dzlay, & + & cldtot, cldcnv, & ! inout + & clouds) ! --- outputs + endif + + elseif(imp_physics == imp_physics_zhao_carr_pdf) then ! zhao/moorthi's prognostic cloud+pdfcld + + call progcld_zhao_carr_pdf (plyr, plvl, tlyr, tvly, qlyr, & ! --- inputs + & qstl, rhly, ccnd(1:IX,1:NLAY,1), cnvw, cnvc, & + & xlat, xlon, slmsk, dz, delp, IX, NLAY, NLP1, & + & deltaq, sup, kdt, me, dzlay, & + & cldtot, cldcnv, & ! inout + & clouds) ! --- outputs + + elseif (imp_physics == imp_physics_gfdl) then ! GFDL cloud scheme + + if (.not. lgfdlmprad) then + call progcld_gfdl_lin (plyr, plvl, tlyr, tvly, qlyr, & ! --- inputs + & qstl, rhly, ccnd(1:IX,1:NLAY,1), cnvw, cnvc, & + & xlat, xlon, slmsk, cldcov, dz, delp, & + & IX, NLAY, NLP1, dzlay, & + & cldtot, cldcnv, & ! inout + & clouds) ! --- outputs + else + + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, xlat, & ! --- inputs + & xlon, slmsk, dz,delp, IX, NLAY, NLP1, cldcov, & + & effrl, effri, effrr, effrs, effr_in, & + & dzlay, & + & cldtot, cldcnv, & ! inout + & clouds) ! --- outputs +! call progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs +! tracer1, xlat, xlon, slmsk, dz, delp, & +! ntrac-1, ntcw-1,ntiw-1,ntrw-1, & +! ntsw-1,ntgl-1,ntclamt-1, & +! IX,NLAY,NLP1, & +! dzlay, & +! cldtot, cldcnv, & ! inout +! clouds) ! --- outputs + endif + + + elseif(imp_physics == imp_physics_fer_hires) then + if (kdt == 1) then + effrl_inout(:,:) = 10. + effri_inout(:,:) = 50. + effrs_inout(:,:) = 250. + endif + + call progcld_fer_hires (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly, & ! --- inputs + & tracer1,xlat,xlon,slmsk,dz,delp, & + & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + & IX,NLAY,NLP1, icloud, uni_cld, & + & lmfshal, lmfdeep2, & + & cldcov(:,1:NLAY),effrl_inout(:,:), & + & effri_inout(:,:), effrs_inout(:,:), & + & dzlay, & + & cldtot, cldcnv, & ! inout + & clouds) ! --- outputs + + elseif(imp_physics == imp_physics_thompson) then ! Thompson MP + + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + + if (icloud == 3) then + call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs + & tracer1,xlat,xlon,slmsk,dz,delp, & + & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + & ntsw-1,ntgl-1, & + & IX, LM, NLP1, uni_cld, lmfshal, lmfdeep2, & + & cldcov(:,1:LM), effrl, effri, effrs, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzlay, gridkm, & + & cldtot, cldcnv, & ! inout + & clouds) ! --- outputs + else + + !-- MYNN PBL or convective GF + !-- use cloud fractions with SGS clouds + do k=1,NLAY + do i=1,IX + clouds(i,k,1) = clouds1(i,k) + enddo + enddo + + ! --- use clduni as with the GFDL microphysics. + ! --- make sure that effr_in=.true. in the input.nml! + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + & xlat, xlon, slmsk, dz, delp, IX, NLAY, NLP1, & + & clouds(:,1:NLAY,1), & + & effrl, effri, effrr, effrs, effr_in , & + & dzlay, & + & cldtot, cldcnv, & ! inout + & clouds) ! --- outputs + endif + + else + ! MYNN PBL or GF convective are not used + + if (icloud == 3) then + call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs + & tracer1,xlat,xlon,slmsk,dz,delp, & + & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + & ntsw-1,ntgl-1, & + & IX, LM, NLP1, uni_cld, lmfshal, lmfdeep2, & + & cldcov(:,1:LM), effrl, effri, effrs, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzlay, gridkm, & + & cldtot, cldcnv, & ! inout + & clouds) ! --- outputs + + else + call progcld_thompson_wsm6 (plyr,plvl,tlyr,qlyr,qstl, & ! --- inputs + & rhly,tracer1,xlat,xlon,slmsk,dz,delp, & + & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + & ntsw-1,ntgl-1, & + & IX, NLAY, NLP1, uni_cld, lmfshal, lmfdeep2, & + & cldcov(:,1:NLAY), cnvw, effrl, effri, effrs, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzlay, & + & cldtot, cldcnv, & ! inout + & clouds) ! --- outputs + endif + endif ! MYNN PBL or GF + + endif ! end if_imp_physics + + do k = 1, NLAY + do i = 1, IX + cld_frac(i,k) = clouds(i,k,1) + cld_lwp(i,k) = clouds(i,k,2) + cld_reliq(i,k) = clouds(i,k,3) + cld_iwp(i,k) = clouds(i,k,4) + cld_reice(i,k) = clouds(i,k,5) + cld_rwp(i,k) = clouds(i,k,6) + cld_rerain(i,k) = clouds(i,k,7) + cld_swp(i,k) = clouds(i,k,8) + cld_resnow(i,k) = clouds(i,k,9) + enddo + enddo + + +!> - Compute SFC/low/middle/high cloud top pressure for each cloud +!! domain for given latitude. +! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; +! --- i=1,2 are low-lat (<45 degree) and pole regions) + + do i =1, IX + rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range +! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range + enddo + + do id = 1, 4 + tem1 = ptopc(id,2) - ptopc(id,1) + + do i =1, IX + ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) + enddo + enddo + + ! Compute cloud decorrelation length + if (idcor == idcor_hogan) then + call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) + endif + if (idcor == idcor_oreopoulos) then + call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) + endif + if (idcor == idcor_con) then + de_lgth(:) = decorr_con + endif + + ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options + if ( iovr == iovr_dcorr .or. iovr == iovr_exp & + & .or. iovr == iovr_exprand) then + call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) + else + de_lgth(:) = 0. + alpha(:,:) = 0. + endif + + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == iovr_exprand) then + do k = 2, nLay + do i = 1, ix + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then + alpha(i,k) = 0.0 + endif + enddo + enddo + endif + +!> - Call gethml() to compute low,mid,high,total, and boundary layer +!! cloud fractions and clouds top/bottom layer indices for low, mid, +!! and high clouds. +! --- compute low, mid, high, total, and boundary layer cloud fractions +! and clouds top/bottom layer indices for low, mid, and high clouds. +! The three cloud domain boundaries are defined by ptopc. The cloud +! overlapping method is defined by control flag 'iovr', which may +! be different for lw and sw radiation programs. + + call gethml & +! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & + & IX, NLAY, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, & +! --- outputs: + & clds, mtop, mbot & + & ) + + return +!................................... + end subroutine radiation_clouds_prop + +!> \ingroup module_radiation_clouds +!> This subroutine computes cloud related quantities using +!! zhao/moorthi's prognostic cloud microphysics scheme. +!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) +!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) +!!\param tlyr (IX,NLAY), model layer mean temperature in K +!!\param tvly (IX,NLAY), model layer virtual temperature in K +!!\param qlyr (IX,NLAY), layer specific humidity in gm/gm +!!\param qstl (IX,NLAY), layer saturate humidity in gm/gm +!!\param rhly (IX,NLAY), layer relative humidity \f$ (=qlyr/qstl) \f$ +!!\param clw (IX,NLAY), layer cloud condensate amount +!!\param xlat (IX), grid latitude in radians, default to pi/2 -> +!! -pi/2 range, otherwise see in-line comment +!!\param xlon (IX), grid longitude in radians (not used) +!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) +!!\param dz (IX,NLAY), layer thickness (km) +!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) +!!\param IX horizontal dimention +!!\param NLAY vertical layer +!!\param NLP1 level dimensions +!!\param uni_cld logical, true for cloud fraction from shoc +!!\param lmfshal logical, mass-flux shallow convection scheme flag +!!\param lmfdeep2 logical, scale-aware mass-flux deep convection scheme flag +!!\param cldcov layer cloud fraction (used when uni_cld=.true.) +!!\param effrl effective radius for liquid water +!!\param effri effective radius for ice water +!!\param effrr effective radius for rain water +!!\param effrs effective radius for snow water +!!\param effr_in logical, if .true. use input effective radii +!!\param dzlay(ix,nlay) distance between model layer centers +!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles +!!\n (:,:,1) - layer total cloud fraction +!!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ +!!\n (:,:,3) - mean eff radius for liq cloud (micron) +!!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ +!!\n (:,:,5) - mean eff radius for ice cloud (micron) +!!\n (:,:,6) - layer rain drop water path (not assigned) +!!\n (:,:,7) - mean eff radius for rain drop (micron) +!!\n (:,:,8) - layer snow flake water path (not assigned) +!!\n (:,:,9) - mean eff radius for snow flake (micron) +!>\section gen_progcld_zhao_carr progcld_zhao_carr General Algorithm +!> @{ + subroutine progcld_zhao_carr & + & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: + & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, & + & uni_cld, lmfshal, lmfdeep2, cldcov, & + & effrl,effri,effrr,effrs,effr_in, & + & dzlay, cldtot, cldcnv, & + & clouds & ! --- outputs: + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: progcld_zhao_carr computes cloud related quantities using ! +! zhao/moorthi's prognostic cloud microphysics scheme. ! +! ! +! abstract: this program computes cloud fractions from cloud ! +! condensates, calculates liquid/ice cloud droplet effective radius, ! +! and computes the low, mid, high, total and boundary layer cloud ! +! fractions and the vertical indices of low, mid, and high cloud ! +! top and base. the three vertical cloud domains are set up in the ! +! initial subroutine "cld_init". ! +! ! +! usage: call progcld_zhao_carr ! +! ! +! subprograms called: gethml ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! +! tlyr (IX,NLAY) : model layer mean temperature in k ! +! tvly (IX,NLAY) : model layer virtual temperature in k ! +! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! +! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! +! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! +! clw (IX,NLAY) : layer cloud condensate amount ! +! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (IX) : grid longitude in radians (not used) ! +! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! dz (ix,nlay) : layer thickness (km) ! +! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! +! IX : horizontal dimention ! +! NLAY,NLP1 : vertical layer/level dimensions ! +! uni_cld : logical - true for cloud fraction from shoc ! +! lmfshal : logical - true for mass flux shallow convection ! +! lmfdeep2 : logical - true for mass flux deep convection ! +! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! ! +! output variables: ! +! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path not assigned ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! *** clouds(:,:,8) - layer snow flake water path not assigned ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! ! +! module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: IX, NLAY, NLP1 + + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, tvly, qlyr, qstl, rhly, clw, cldcov, delp, dz, & + & effrl, effri, effrr, effrs, dzlay + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk + +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + +! --- local variables: + real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & + & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2, tem3 + + integer :: i, k, id, nf + +! --- constant values +! real (kind=kind_phys), parameter :: xrc3 = 200. + real (kind=kind_phys), parameter :: xrc3 = 100. +! +!===> ... begin here +! !> - Assgin liquid/ice/rain/snow cloud effective radius from input or predefined values. if(effr_in) then do k = 1, NLAY @@ -675,24 +1224,6 @@ subroutine progcld1 & enddo endif -!> - Compute SFC/low/middle/high cloud top pressure for each cloud -!! domain for given latitude. -! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -! --- i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . do k = 1, NLAY @@ -847,66 +1378,10 @@ subroutine progcld1 & clouds(i,k,9) = res(i,k) enddo enddo - -! --- ... estimate clouds decorrelation length in km -! this is only a tentative test, need to consider change later - - if ( iovr == 3 ) then - do i = 1, ix - de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) - enddo - endif - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. The three cloud domain boundaries are defined by -!! ptopc. The cloud overlapping method is defined by control flag -!! 'iovr', which may be different for lw and sw radiation programs. - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - ! return !................................... - end subroutine progcld1 + end subroutine progcld_zhao_carr !----------------------------------- !> @} @@ -936,9 +1411,6 @@ end subroutine progcld1 !!\param lmfshal flag for mass-flux shallow convection scheme in the cloud fraction calculation !!\param lmfdeep2 flag for mass-flux deep convection scheme in the cloud fraction calculation !!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) !!\param clouds (IX,NLAY,NF_CLDS), cloud profiles !!\n (:,:,1) - layer total cloud fraction !!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ @@ -949,10 +1421,6 @@ end subroutine progcld1 !!\n (:,:,7) - mean eff radius for rain drop (micron) !!\n (:,:,8) - layer snow flake water path \f$(g/m^2)\f$ !!\n (:,:,9) - mean eff radius for snow flake (micron) -!!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl -!!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops -!!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases -!!\param de_lgth (IX), clouds decorrelation length (km) !>\section gen_progcld2 progcld2 General Algorithm for the F-A MP scheme !> @{ subroutine progcld2 & @@ -960,8 +1428,8 @@ subroutine progcld2 & & xlat,xlon,slmsk,dz,delp, & & ntrac, ntcw, ntiw, ntrw, & & IX, NLAY, NLP1, lmfshal, lmfdeep2, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, cldtot, cldcnv, & + & clouds & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -1007,9 +1475,6 @@ subroutine progcld2 & ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -1022,12 +1487,6 @@ subroutine progcld2 & ! clouds(:,:,7) - mean eff radius for rain drop (micron) ! ! *** clouds(:,:,8) - layer snow flake water path not assigned ! ! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -1060,25 +1519,13 @@ subroutine progcld2 & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha - - integer, dimension(:,:), intent(out) :: mtop,mbot - ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 @@ -1091,15 +1538,6 @@ subroutine progcld2 & ! !===> ... begin here ! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - do k = 1, NLAY do i = 1, IX cldtot(i,k) = 0.0 @@ -1122,22 +1560,6 @@ subroutine progcld2 & clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) enddo enddo -!> - Find top pressure for each cloud domain for given latitude. -!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . @@ -1265,57 +1687,6 @@ subroutine progcld2 & clouds(i,k,9) = res(i,k) enddo enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - ! return !................................... @@ -1351,9 +1722,6 @@ end subroutine progcld2 !!\param kdt !!\param me print control flag !!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) !!\param clouds (ix,nlay,nf_clds), cloud profiles !!\n (:,:,1) - layer total cloud fraction !!\n (:,:,2) - layer cloud liq water path (g/m**2) @@ -1364,25 +1732,20 @@ end subroutine progcld2 !!\n (:,:,7) - mean eff radius for rain drop (micron) !!\n (:,:,8) - layer snow flake water path not assigned !!\n (:,:,9) - mean eff radius for snow flake(micron) -!!\param clds (ix,5), fraction of clouds for low, mid, hi, tot, bl -!!\param mtop (ix,3), vertical indices for low, mid, hi cloud tops -!!\param mbot (ix,3), vertical indices for low, mid, hi cloud bases -!!\param de_lgth (ix), clouds decorrelation length (km) -!!\param alpha (IX,NLAY), alpha decorrelation parameter -!>\section gen_progcld3 progcld3 General Algorithm +!>\section gen_progcld_zhao_carr_pdf progcld_zhao_carr_pdf General Algorithm !! @{ - subroutine progcld3 & + subroutine progcld_zhao_carr_pdf & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: & xlat,xlon,slmsk, dz, delp, & & ix, nlay, nlp1, & & deltaq,sup,kdt,me, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, cldtot, cldcnv, & + & clouds & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld3 computes cloud related quantities using ! +! subprogram: progcld_zhao_carr_pdf computes cloud related quantities using ! ! zhao/moorthi's prognostic cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! @@ -1392,7 +1755,7 @@ subroutine progcld3 & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld3 ! +! usage: call progcld_zhao_carr_pdf ! ! ! ! subprograms called: gethml ! ! ! @@ -1425,10 +1788,6 @@ subroutine progcld3 & ! deltaq(ix,nlay) : half total water distribution width ! ! sup : supersaturation ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! - ! ! ! output variables: ! ! clouds(ix,nlay,nf_clds) : cloud profiles ! @@ -1441,12 +1800,6 @@ subroutine progcld3 & ! clouds(:,:,7) - mean eff radius for rain drop (micron) ! ! *** clouds(:,:,8) - layer snow flake water path not assigned ! ! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (ix,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (ix,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (ix,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -1479,25 +1832,13 @@ subroutine progcld3 & & slmsk integer :: me - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha - - integer, dimension(:,:), intent(out) :: mtop,mbot - ! --- local variables: real (kind=kind_phys), dimension(ix,nlay) :: cldtot, cldcnv, & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - real (kind=kind_phys) :: ptop1(ix,nk_clds+1), rxlat(ix) - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 @@ -1506,15 +1847,6 @@ subroutine progcld3 & ! !===> ... begin here ! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - do k = 1, nlay do i = 1, ix cldtot(i,k) = 0.0 @@ -1558,23 +1890,6 @@ subroutine progcld3 & enddo endif -!> -# Find top pressure (ptopc) for each cloud domain for given latitude. -! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,l,m,h; -! --- i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, ix - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - !> -# Calculate liquid/ice condensate path in \f$ g/m^2 \f$ do k = 1, nlay @@ -1705,60 +2020,10 @@ subroutine progcld3 & clouds(i,k,9) = res(i,k) enddo enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> -# Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! the three cloud domain boundaries are defined by ptopc. the cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & ix,nlay, & -! --- outputs: - & clds, mtop, mbot & - & ) - - ! return !................................... - end subroutine progcld3 + end subroutine progcld_zhao_carr_pdf !! @} !----------------------------------- @@ -1788,9 +2053,6 @@ end subroutine progcld3 !!\param nlay vertical layer dimension !!\param nlp1 vertical level dimension !!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) !!\param clouds (ix,nlay,nf_clds), cloud profiles !!\n clouds(:,:,1) - layer total cloud fraction !!\n clouds(:,:,2) - layer cloud liquid water path (\f$g m^{-2}\f$) @@ -1801,24 +2063,19 @@ end subroutine progcld3 !!\n clouds(:,:,7) - mean effective radius for rain drop (micron) !!\n clouds(:,:,8) - layer snow flake water path (not assigned) (\f$g m^{-2}\f$) (not assigned) !!\n clouds(:,:,9) - mean effective radius for snow flake (micron) -!!\param clds fraction of clouds for low, mid, hi cloud tops -!!\param mtop vertical indices for low, mid, hi cloud tops -!!\param mbot vertical indices for low, mid, hi cloud bases -!!\param de_lgth clouds decorrelation length (km) -!!\param alpha (IX,NLAY), alpha decorrelation parameter -!>\section gen_progcld4 progcld4 General Algorithm +!>\section gen_progcld_gfdl_lin progcld_gfdl_lin General Algorithm !! @{ - subroutine progcld4 & + subroutine progcld_gfdl_lin & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: & xlat,xlon,slmsk,cldtot, dz, delp, & & IX, NLAY, NLP1, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, cldtot1, cldcnv, & + & clouds & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld4 computes cloud related quantities using ! +! subprogram: progcld_gfdl_lin computes cloud related quantities using ! ! GFDL Lin MP prognostic cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! @@ -1828,7 +2085,7 @@ subroutine progcld4 & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld4 ! +! usage: call progcld_gfdl_lin ! ! ! ! subprograms called: gethml ! ! ! @@ -1859,9 +2116,6 @@ subroutine progcld4 & ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -1874,12 +2128,6 @@ subroutine progcld4 & ! clouds(:,:,7) - mean eff radius for rain drop (micron) ! ! *** clouds(:,:,8) - layer snow flake water path not assigned ! ! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -1904,28 +2152,17 @@ subroutine progcld4 & & tlyr, tvly, qlyr, qstl, rhly, clw, cldtot, cnvw, cnvc, & & delp, dz, dzlay - real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & - & slmsk - - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk - integer, dimension(:,:), intent(out) :: mtop,mbot + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot1 +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 @@ -1934,15 +2171,6 @@ subroutine progcld4 & ! !===> ... begin here ! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - !> - Assign liquid/ice/rain/snow cloud doplet effective radius as default value. do k = 1, NLAY do i = 1, IX @@ -1978,23 +2206,6 @@ subroutine progcld4 & enddo endif -!> - Compute top pressure for each cloud domain for given latitude. -!!\n ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - !> - Compute liquid/ice condensate path in \f$g m^{-2}\f$. do k = 1, NLAY @@ -2067,6 +2278,12 @@ subroutine progcld4 & enddo enddo + do k = 1, NLAY + do i = 1, IX + cldtot1(i,k) = cldtot(i,k) + enddo + enddo + ! do k = 1, NLAY do i = 1, IX @@ -2081,58 +2298,10 @@ subroutine progcld4 & clouds(i,k,9) = res(i,k) enddo enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - ! return !................................... - end subroutine progcld4 + end subroutine progcld_gfdl_lin !! @} !----------------------------------- @@ -2167,9 +2336,6 @@ end subroutine progcld4 !>\param nlay vertical layer dimension !>\param nlp1 vertical level dimension !!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) !>\param clouds (ix,nlay,nf_clds), cloud profiles !!\n clouds(:,:,1) - layer totoal cloud fraction !!\n clouds(:,:,2) - layer cloud liquid water path (\f$g m^{-2}\f$) @@ -2180,11 +2346,6 @@ end subroutine progcld4 !!\n clouds(:,:,7) - mean effective radius for rain drop (micron) !!\n clouds(:,:,8) - layer snow flake water path (\f$g m^{-2}\f$) !!\n clouds(:,:,9) - mean effective radius for snow flake (micron) -!>\param clds (ix,5), fraction of clouds for low, mid, hi, tot, bl -!>\param mtop (ix,3), vertical indices for low, mid, hi cloud tops -!>\param mbot (ix,3), vertical indices for low, mid, hi cloud bases -!>\param de_lgth clouds decorrelation length (km) -!!\param alpha (IX,NLAY), alpha decorrelation parameter !>\section gen_progcld4o progcld4o General Algorithm !! @{ subroutine progcld4o & @@ -2192,8 +2353,8 @@ subroutine progcld4o & & xlat,xlon,slmsk, dz, delp, & & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl,ntclamt, & & IX, NLAY, NLP1, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, cldtot, cldcnv, & + & clouds & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -2238,9 +2399,6 @@ subroutine progcld4o & ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -2289,25 +2447,13 @@ subroutine progcld4o & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha - - integer, dimension(:,:), intent(out) :: mtop,mbot - ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 real (kind=kind_phys), dimension(IX,NLAY) :: cldtot @@ -2317,15 +2463,6 @@ subroutine progcld4o & ! !===> ... begin here ! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - !> - Assign liquid/ice/rain/snow cloud droplet effective radius as default value. do k = 1, NLAY do i = 1, IX @@ -2343,23 +2480,6 @@ subroutine progcld4o & enddo enddo -!> - Compute top pressure for each cloud domain for given latitude. -!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - !> - Compute liquid/ice condensate path in \f$g m^{-2}\f$ do k = 1, NLAY @@ -2448,54 +2568,6 @@ subroutine progcld4o & clouds(i,k,9) = rei(i,k) enddo enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low, mid, high, total, and boundary layer cloud fractions -!! and clouds top/bottom layer indices for low, mid, and high clouds. -!! The three cloud domain boundaries are defined by ptopc. The cloud -!! overlapping method is defined by control flag 'iovr', which may -!! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - ! return !................................... @@ -2507,20 +2579,20 @@ end subroutine progcld4o !> \ingroup module_radiation_clouds !! This subroutine computes cloud related quantities using !! Ferrier-Aligo cloud microphysics scheme. - subroutine progcld5 & + subroutine progcld_fer_hires & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & & ntrac,ntcw,ntiw,ntrw, & & IX, NLAY, NLP1, icloud, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, cldtot, cldcnv, & + & clouds & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld5 computes cloud related quantities using ! +! subprogram: progcld_fer_hires computes cloud related quantities using ! ! Ferrier-Aligo cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! @@ -2530,7 +2602,7 @@ subroutine progcld5 & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld5 ! +! usage: call progcld_fer_hires ! ! ! ! subprograms called: gethml ! ! ! @@ -2564,9 +2636,6 @@ subroutine progcld5 & ! lmfdeep2 : logical - true for mass flux deep convection ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -2579,12 +2648,6 @@ subroutine progcld5 & ! clouds(:,:,7) - mean eff radius for rain drop (micron) ! ! *** clouds(:,:,8) - layer snow flake water path not assigned ! ! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -2620,25 +2683,13 @@ subroutine progcld5 & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha - - integer, dimension(:,:), intent(out) :: mtop,mbot - ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 @@ -2651,15 +2702,6 @@ subroutine progcld5 & ! !===> ... begin here ! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - do k = 1, NLAY do i = 1, IX cldtot(i,k) = 0.0 @@ -2700,22 +2742,6 @@ subroutine progcld5 & clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) enddo enddo -!> - Find top pressure for each cloud domain for given latitude. -!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . @@ -2811,93 +2837,42 @@ subroutine progcld5 & if (cldtot(i,k) >= climit) then tem1 = 1.0 / max(climit2, cldtot(i,k)) cwp(i,k) = cwp(i,k) * tem1 - cip(i,k) = cip(i,k) * tem1 - crp(i,k) = crp(i,k) * tem1 - csp(i,k) = csp(i,k) * tem1 - endif - enddo - enddo - endif - do k = 1, NLAY - do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) - clouds(i,k,7) = rer(i,k) - !mz inflg .ne.5 - clouds(i,k,8) = 0. - clouds(i,k,9) = 10. -!mz for diagnostics? - re_cloud(i,k) = rew(i,k) - re_ice(i,k) = rei(i,k) - re_snow(i,k) = 10. - - enddo - enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - + cip(i,k) = cip(i,k) * tem1 + crp(i,k) = crp(i,k) * tem1 + csp(i,k) = csp(i,k) * tem1 + endif + enddo + enddo + endif + do k = 1, NLAY + do i = 1, IX + clouds(i,k,1) = cldtot(i,k) + clouds(i,k,2) = cwp(i,k) + clouds(i,k,3) = rew(i,k) + clouds(i,k,4) = cip(i,k) + clouds(i,k,5) = rei(i,k) + clouds(i,k,6) = crp(i,k) + clouds(i,k,7) = rer(i,k) + !mz inflg .ne.5 + clouds(i,k,8) = 0. + clouds(i,k,9) = 10. +!mz for diagnostics? + re_cloud(i,k) = rew(i,k) + re_ice(i,k) = rei(i,k) + re_snow(i,k) = 10. + enddo + enddo ! return !................................... - end subroutine progcld5 + end subroutine progcld_fer_hires !................................... -!mz: this is the original progcld5 for Thompson MP (and WSM6), -! to be replaced by the GSL version of progcld6 for Thompson MP - subroutine progcld6 & +!mz: this is the original progcld_fer_hires for Thompson MP (and WSM6), +! to be replaced by the GSL version of progcld_thompson_wsm6 for Thompson MP + subroutine progcld_thompson_wsm6 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & @@ -2905,13 +2880,13 @@ subroutine progcld6 & & uni_cld, lmfshal, lmfdeep2, cldcov, cnvw, & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, cldtot, cldcnv, & + & clouds & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld6 computes cloud related quantities using ! +! subprogram: progcld_thompson_wsm6 computes cloud related quantities using ! ! Thompson/WSM6 cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! @@ -2921,7 +2896,7 @@ subroutine progcld6 & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld6 ! +! usage: call progcld_thompson_wsm6 ! ! ! ! subprograms called: gethml ! ! ! @@ -3006,25 +2981,13 @@ subroutine progcld6 & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha - - integer, dimension(:,:), intent(out) :: mtop,mbot - ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 @@ -3036,15 +2999,6 @@ subroutine progcld6 & ! !===> ... begin here - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - do k = 1, NLAY do i = 1, IX cldtot(i,k) = 0.0 @@ -3087,22 +3041,6 @@ subroutine progcld6 & & + clw(i,k,ntrw) + cnvw(i,k) enddo enddo -!> - Find top pressure for each cloud domain for given latitude. -!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . @@ -3247,59 +3185,10 @@ subroutine progcld6 & enddo enddo - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if ( iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - return !............................................ - end subroutine progcld6 + end subroutine progcld_thompson_wsm6 !............................................ !mz @@ -3322,8 +3211,8 @@ subroutine progcld_thompson & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, latdeg, julian, yearlen, gridkm, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, gridkm, cldtot, cldcnv, & + & clouds & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -3384,11 +3273,6 @@ subroutine progcld_thompson & ! clouds(:,:,7) - mean eff radius for rain drop (micron) ! ! clouds(:,:,8) - layer snow flake water path not assigned ! ! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -3423,20 +3307,11 @@ subroutine progcld_thompson & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - - real(kind=kind_phys), dimension(:), intent(in) :: latdeg, gridkm - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen + real(kind=kind_phys), dimension(:), intent(in) :: gridkm ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha - - integer, dimension(:,:), intent(out) :: mtop,mbot - ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & & cwp, cip, crp, csp, rew, rei, res, rer @@ -3444,8 +3319,6 @@ subroutine progcld_thompson & real (kind=kind_phys), dimension(NLAY) :: cldfra1d, qv1d, & & qc1d, qi1d, qs1d, dz1d, p1d, t1d - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: clwmin, tem1 real (kind=kind_phys) :: corr, xland, snow_mass_factor real (kind=kind_phys), parameter :: max_relh = 1.5 @@ -3481,23 +3354,6 @@ subroutine progcld_thompson & enddo enddo -!> - Find top pressure for each cloud domain for given latitude. -!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . !> - Since using Thompson MP, assume 1 percent of snow is actually in !! ice sizes. @@ -3626,56 +3482,6 @@ subroutine progcld_thompson & lwp_ex(i) = lwp_ex(i)*1.E-3 iwp_ex(i) = iwp_ex(i)*1.E-3 enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if ( iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - ! return @@ -3709,9 +3515,6 @@ end subroutine progcld_thompson !!\param effrs (IX,NLAY), effective radius for snow water !!\param effr_in logical - if .true. use input effective radii !!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) !!\param clouds (IX,NLAY,NF_CLDS), cloud profiles !!\n (:,:,1) - layer total cloud fraction !!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ @@ -3722,19 +3525,14 @@ end subroutine progcld_thompson !!\n (:,:,7) - mean eff radius for rain drop (micron) !!\n (:,:,8) - layer snow flake water path !!\n (:,:,9) - mean eff radius for snow flake (micron) -!!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl -!!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops -!!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases -!!\param de_lgth (IX), clouds decorrelation length (km) -!!\param alpha (IX,NLAY), alpha decorrelation parameter !>\section gen_progclduni progclduni General Algorithm !> @{ subroutine progclduni & & ( plyr,plvl,tlyr,tvly,ccnd,ncnd, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, & & effrl,effri,effrr,effrs,effr_in, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, cldtot1, cldcnv, & + & clouds & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -3783,9 +3581,6 @@ subroutine progclduni & ! dz (ix,nlay) : layer thickness (km) ! ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -3834,42 +3629,21 @@ subroutine progclduni & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot1 ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha - - integer, dimension(:,:), intent(out) :: mtop,mbot - ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, cwp, cip, & & crp, csp, rew, rei, res, rer real (kind=kind_phys), dimension(IX,NLAY,ncnd) :: cndf - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: tem1, tem2, tem3 integer :: i, k, id, nf, n ! !===> ... begin here -! -! do nf=1,nf_clds -! do k=1,nlay -! do i=1,ix -! clouds(i,k,nf) = 0.0 -! enddo -! enddo -! enddo ! do k = 1, NLAY do i = 1, IX @@ -4006,6 +3780,12 @@ subroutine progclduni & enddo enddo endif + + do k = 1, NLAY + do i = 1, IX + cldtot1(i,k) = cldtot(i,k) + enddo + enddo ! do k = 1, NLAY do i = 1, IX @@ -4020,73 +3800,6 @@ subroutine progclduni & clouds(i,k,9) = res(i,k) enddo enddo - -!> -# Find top pressure for each cloud domain for given latitude. -! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -! --- i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - ! return !................................... @@ -4118,7 +3831,8 @@ end subroutine progclduni !! @{ subroutine gethml & & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & ! --- inputs: - & IX, NLAY, & + & IX, NLAY, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, & & clds, mtop, mbot & ! --- outputs: & ) @@ -4178,6 +3892,13 @@ subroutine gethml & ! --- inputs: integer, intent(in) :: IX, NLAY + integer, intent(in) :: & + & iovr_rand, ! Flag for random cloud overlap method + & iovr_maxrand, ! Flag for maximum-random cloud overlap method + & iovr_max, ! Flag for maximum cloud overlap method + & iovr_dcorr, ! Flag for decorrelation-length cloud overlap method + & iovr_exp, ! Flag for exponential cloud overlap method + & iovr_exprand ! Flag for exponential-random cloud overlap method real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, ptop1, & & cldtot, cldcnv, dz @@ -4222,7 +3943,7 @@ subroutine gethml & kinc = 1 endif ! end_if_ivflip - if ( iovr == 0 ) then ! random overlap + if ( iovr == iovr_rand ) then ! random overlap do k = kstr, kend, kinc do i = 1, IX @@ -4241,7 +3962,7 @@ subroutine gethml & clds(i,4) = 1.0 - cl1(i) ! save total cloud enddo - elseif ( iovr == 1 ) then ! max/ran overlap + elseif ( iovr == iovr_maxrand ) then ! max/ran overlap do k = kstr, kend, kinc do i = 1, IX @@ -4265,7 +3986,7 @@ subroutine gethml & clds(i,4) = 1.0 - cl1(i) * cl2(i) ! save total cloud enddo - elseif ( iovr == 2 ) then ! maximum overlap all levels + elseif ( iovr == iovr_max ) then ! maximum overlap all levels cl1(:) = 0.0 @@ -4286,7 +4007,7 @@ subroutine gethml & clds(i,4) = cl1(i) ! save total cloud enddo - elseif ( iovr == 3 ) then ! random if clear-layer divided, + elseif ( iovr == iovr_dcorr ) then ! random if clear-layer divided, ! otherwise de-corrlength method do i = 1, ix dz1(i) = - dz(i,kstr) @@ -4318,7 +4039,7 @@ subroutine gethml & clds(i,4) = 1.0 - cl1(i) * cl2(i) ! save total cloud enddo - elseif ( iovr == 4 .or. iovr == 5 ) then ! exponential overlap (iovr=4), or + elseif ( iovr == iovr_exp .or. iovr == iovr_exprand ) then ! exponential overlap (iovr=4), or ! exponential-random (iovr=5); ! distinction defined by alpha @@ -4399,7 +4120,7 @@ subroutine gethml & if (kth2(i) == 0) kbt2(i) = k kth2(i) = kth2(i) + 1 - if ( iovr == 0 ) then + if ( iovr == iovr_rand ) then cl2(i) = cl2(i) + ccur - cl2(i)*ccur else cl2(i) = max( cl2(i), ccur ) @@ -4481,7 +4202,7 @@ subroutine gethml & if (kth2(i) == 0) kbt2(i) = k kth2(i) = kth2(i) + 1 - if ( iovr == 0 ) then + if ( iovr == iovr_rand ) then cl2(i) = cl2(i) + ccur - cl2(i)*ccur else cl2(i) = max( cl2(i), ccur ) From 779c432ace675eab5bd58a895c730c0b65eed047 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 14 Feb 2022 15:38:20 -0700 Subject: [PATCH 068/217] update some flag units and remove GFS_suite_interstitial dependency on NSSL MP --- physics/GFS_PBL_generic.meta | 8 ++++---- physics/GFS_rrtmg_pre.meta | 4 ++-- physics/GFS_suite_interstitial.F90 | 11 ++++------- physics/GFS_suite_interstitial.meta | 14 +++++++++++--- physics/module_MYNNPBL_wrapper.meta | 2 +- physics/mp_nssl.meta | 12 ++++++------ 6 files changed, 28 insertions(+), 23 deletions(-) diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 3cebf7598..9e0d68a7d 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -283,14 +283,14 @@ [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in @@ -710,14 +710,14 @@ [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 0cedfa3ca..e1af2da3b 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -208,14 +208,14 @@ [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in [nssl_invertccn] standard_name = nssl_invertccn long_name = flag to invert CCN in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 52bc65c2c..044912e07 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -715,14 +715,12 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_nssl, nssl_invertccn, nssl_ccn_on, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& - index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & + index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nssl_cccn, nwfa, spechum, ldiag3d, & qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, errmsg, errflg) use machine, only: kind_phys - use module_mp_nssl_2mom, only: qccn use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber - implicit none ! interface variables @@ -749,7 +747,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr real(kind=kind_phys), dimension(:,:,:), intent(inout) :: gq0 real(kind=kind_phys), dimension(:,:,:), intent(inout) :: clw real(kind=kind_phys), dimension(:,:), intent(in) :: prsl - real(kind=kind_phys), intent(in) :: con_rd, con_eps + real(kind=kind_phys), intent(in) :: con_rd, con_eps, nssl_cccn real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp real(kind=kind_phys), dimension(:,:), intent(in) :: spechum @@ -759,7 +757,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ! local variables real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys integer :: i,k,n,tracers,idtend - real(kind=kind_phys) :: liqm, icem, xccn, xcwmas, xccw, xcimas ! , qccn + real(kind=kind_phys) :: liqm, icem, xccn, xcwmas, xccw, xcimas, qccn real(kind=kind_phys) :: rho, orho real(kind=kind_phys), dimension(im,levs) :: qv_mp !< kg kg-1 (dry mixing ratio) @@ -869,7 +867,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr if ( imp_physics == imp_physics_nssl ) then liqm = con_pi/6.*1.e3*(18.e-6)**3 ! 4./3.*con_pi*1.e-12 icem = con_pi/6.*1.e3*(120.e-6)**3 ! 4./3.*con_pi*3.2768*1.e-14*890. - ! qccn = nssl_cccn/1.225 + qccn = nssl_cccn/1.225 !1.225 is a reference air density and should match what is used in module_mp_nssl_2mom.F90 (rho00) do k=1,levs do i=1,im ! check number of available ccn @@ -1043,4 +1041,3 @@ subroutine GFS_suite_interstitial_5_run (im, levs, ntrac, ntcw, ntiw, nn, gq0, c end subroutine GFS_suite_interstitial_5_run end module GFS_suite_interstitial_5 - diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 1b710b8b5..1c0bbed47 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_rad_reset type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90,module_mp_nssl_2mom.F90 + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 ######################################################################## [ccpp-arg-table] @@ -1677,14 +1677,14 @@ [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in [nssl_invertccn] standard_name = nssl_invertccn long_name = flag to invert CCN in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in @@ -1784,6 +1784,14 @@ type = real kind = kind_phys intent = in +[nssl_cccn] + standard_name = nssl_ccn_concentration + long_name = CCN concentration + units = m-3 + dimensions = () + type = real + kind = kind_phys + intent = in [nwfa] standard_name = mass_number_concentration_of_hygroscopic_aerosols long_name = number concentration of water-friendly aerosols diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 26620ea7f..8d51a4ce8 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1276,7 +1276,7 @@ [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 6643b5356..43350fd10 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -168,21 +168,21 @@ [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in [nssl_invertccn] standard_name = nssl_invertccn long_name = flag to invert CCN in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in @@ -565,21 +565,21 @@ [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in [nssl_hail_on] standard_name = nssl_hail_on long_name = hail activation flag in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in [nssl_invertccn] standard_name = nssl_invertccn long_name = flag to invert CCN in NSSL micro - units = none + units = flag dimensions = () type = logical intent = in From b10418456037a5481221e00f42e404fa5408ec21 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 14 Feb 2022 16:02:54 -0700 Subject: [PATCH 069/217] convert argument arrays in mp_nssl.F90 to assumed-shape --- physics/mp_nssl.F90 | 58 ++++++++++++++++++++++----------------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 6d1c16420..8ce37ecaf 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -168,39 +168,39 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & integer, intent(in) :: mpirank ! Hydrometeors logical, intent(in ) :: convert_dry_rho - real(kind_phys), intent(inout) :: spechum(1:ncol,1:nlev) - real(kind_phys), intent(inout) :: cccn(:,:) ! (1:ncol,1:nlev) - real(kind_phys), intent(inout) :: cccna(:,:) ! (1:ncol,1:nlev) - 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) :: qhl(:,:) ! (1:ncol,1:nlev) ! hail - 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) :: chl(:,:) ! (1:ncol,1:nlev) ! hail number - real(kind_phys), intent(inout) :: vh(1:ncol,1:nlev) ! graupel volume - real(kind_phys), intent(inout) :: vhl(:,:) ! (1:ncol,1:nlev) ! hail volume + real(kind_phys), intent(inout) :: spechum(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccn(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccna(:,:) !(1:ncol,1:nlev) + 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) :: qhl(:,:) !(1:ncol,1:nlev) hail + 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) :: chl(:,:) !(1:ncol,1:nlev) hail number + real(kind_phys), intent(inout) :: vh (:,:) !(1:ncol,1:nlev) graupel volume + real(kind_phys), intent(inout) :: vhl(:,:) !(1:ncol,1:nlev) hail volume ! State variables and timestep information - real(kind_phys), intent(inout) :: tgrs(1:ncol,1:nlev) - real(kind_phys), intent(in ) :: prsl(1:ncol,1:nlev) - real(kind_phys), intent(in ) :: prslk(1:ncol,1:nlev) - real(kind_phys), intent(in ) :: phii(1:ncol,1:nlev+1) - real(kind_phys), intent(in ) :: omega(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: tgrs (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prsl (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prslk(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: phii (:,:) !(1:ncol,1:nlev+1) + real(kind_phys), intent(in ) :: omega(:,:) !(1:ncol,1:nlev) real(kind_phys), intent(in ) :: dtp ! Precip/rain/snow/graupel fall amounts and fraction of frozen precip - real(kind_phys), intent( out) :: prcp(1:ncol) - real(kind_phys), intent( out) :: rain(1:ncol) - real(kind_phys), intent( out) :: graupel(1:ncol) - real(kind_phys), intent( out) :: ice(1:ncol) - real(kind_phys), intent( out) :: snow(1:ncol) - real(kind_phys), intent( out) :: sr(1:ncol) + real(kind_phys), intent( out) :: prcp (:) !(1:ncol) + real(kind_phys), intent( out) :: rain (:) !(1:ncol) + real(kind_phys), intent( out) :: graupel(:) !(1:ncol) + real(kind_phys), intent( out) :: ice (:) !(1:ncol) + real(kind_phys), intent( out) :: snow (:) !(1:ncol) + real(kind_phys), intent( out) :: sr (:) !(1:ncol) ! Radar reflectivity - real(kind_phys), intent(inout) :: refl_10cm(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: refl_10cm(:,:) !(1:ncol,1:nlev) logical, intent(in ) :: do_radar_ref, first_time_step ! Cloud effective radii real(kind_phys), intent(inout) :: re_cloud(:,:) ! (1:ncol,1:nlev) From 10fa17e895ecd21db0d24d1cef7b12523cabce40 Mon Sep 17 00:00:00 2001 From: wx20hw Date: Wed, 16 Feb 2022 20:03:11 +0000 Subject: [PATCH 070/217] canopy height dependant czil --- physics/module_sf_noahmplsm.f90 | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index b602a683e..0fc4e8948 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -1895,6 +1895,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) :: csigmaf0 real (kind=kind_phys) :: csigmaf1 real (kind=kind_phys) :: csigmafveg + real (kind=kind_phys) :: czil1 real (kind=kind_phys) :: cdmnv real (kind=kind_phys) :: ezpdv @@ -2251,8 +2252,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in z0hwrf = z0wrf elseif (opt_trs == 2) then z0wrf = fveg * z0m + (1.0 - fveg) * z0mg - z0hwrf = fveg * z0m*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0m)) & - +(1.0 - fveg) * z0mg*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0mg)) +! z0hwrf = fveg * z0m*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0m)) & +! +(1.0 - fveg) * z0mg*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0mg)) + czil1=10.0 ** (- (0.40/0.07) * parameters%hvt) + z0hwrf = fveg * z0m*exp(-czil1*0.4*258.2*sqrt(ustarx*z0m)) & + +(1.0 - fveg) * z0mg*exp(-czil1*0.4*258.2*sqrt(ustarx*z0mg)) elseif (opt_trs == 3) then z0wrf = fveg * z0m + (1.0 - fveg) * z0mg if (vegtyp.le.5) then @@ -2309,7 +2313,9 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in if (opt_trs == 1) then z0hwrf = z0wrf elseif (opt_trs == 2) then - z0hwrf = z0wrf*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0wrf)) +! z0hwrf = z0wrf*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0wrf)) + czil1=10.0 ** (- (0.40/0.07) * parameters%hvt) + z0hwrf = z0wrf*exp(-czil1*0.4*258.2*sqrt(ustarx*z0wrf)) elseif (opt_trs == 3) then if (vegtyp.le.5) then z0hwrf = z0wrf @@ -3866,7 +3872,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: laisune !sunlit leaf area index, one-sided (m2/m2),effective real (kind=kind_phys) :: laishae !shaded leaf area index, one-sided (m2/m2),effective - real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx + real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx,czil1 real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 integer :: k !index @@ -4003,7 +4009,9 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if (opt_trs == 1) then z0h = z0m elseif (opt_trs == 2) then - z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) +! z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) + czil1= 10.0 ** (- (0.40/0.07) * hcan) + z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) elseif (opt_trs == 3) then if (vegtyp.le.5) then z0h = z0m @@ -4581,7 +4589,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: fh2 !monin-obukhov heat adjustment at 2m real (kind=kind_phys) :: ch2 !surface exchange at 2m - real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx + real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx,czil1 real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 integer :: iter !iteration index @@ -4631,7 +4639,9 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if (opt_trs == 1) then z0h = z0m elseif (opt_trs == 2) then - z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) +! z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) + czil1= 10.0 ** (- (0.40/0.07) * parameters%hvt) + z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) elseif (opt_trs == 3) then if (vegtyp.le.5) then z0h = z0m From 242dcc985b031d875d59d59a1fc3d61c22c5fa00 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Tue, 22 Feb 2022 19:38:26 +0000 Subject: [PATCH 071/217] updated the radiation code based on review's suggestions --- physics/GFS_cloud_diagnostics.F90 | 124 +- physics/GFS_rrtmgp_cloud_overlap_pre.F90 | 29 +- physics/GFS_rrtmgp_gfdlmp_pre.F90 | 2 +- physics/GFS_rrtmgp_setup.F90 | 10 +- physics/radiation_cloud_overlap.F90 | 25 +- physics/radiation_clouds.f | 1889 +++++++--------------- physics/radlw_main.F90 | 2 +- physics/radsw_main.F90 | 2 +- 8 files changed, 630 insertions(+), 1453 deletions(-) diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/GFS_cloud_diagnostics.F90 index 214d12bbd..2258cd73f 100644 --- a/physics/GFS_cloud_diagnostics.F90 +++ b/physics/GFS_cloud_diagnostics.F90 @@ -46,10 +46,10 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m implicit none ! Inputs - integer, intent(in) :: & - nCol, & ! Number of horizontal grid-points - nLev ! Number of vertical-layers - integer, intent(in) :: & + integer, intent(in) :: & + nCol, & ! Number of horizontal grid-points + nLev ! Number of vertical-layers + integer, intent(in) :: & iovr_rand, & ! Flag for random cloud overlap method iovr_maxrand, & ! Flag for maximum-random cloud overlap method iovr_max, & ! Flag for maximum cloud overlap method @@ -57,33 +57,33 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m iovr_exp, & ! Flag for exponential cloud overlap method iovr_exprand ! Flag for exponential-random cloud overlap method logical, intent(in) :: & - lsswr, & ! Call SW radiation? - lslwr ! Call LW radiation - real(kind_phys), intent(in) :: & - con_pi ! Physical constant: pi - real(kind_phys), dimension(:), intent(in) :: & - lat, & ! Latitude - de_lgth ! Decorrelation length + lsswr, & ! Call SW radiation? + lslwr ! Call LW radiation + real(kind_phys), intent(in) :: & + con_pi ! Physical constant: pi + real(kind_phys), dimension(:), intent(in) :: & + lat, & ! Latitude + de_lgth ! Decorrelation length real(kind_phys), dimension(:,:), intent(in) :: & - p_lay, & ! Pressure at model-layer - cld_frac ! Total cloud fraction + p_lay, & ! Pressure at model-layer + cld_frac ! Total cloud fraction real(kind_phys), dimension(:,:), intent(in) :: & - p_lev ! Pressure at model interfaces + p_lev ! Pressure at model interfaces real(kind_phys), dimension(:,:), intent(in) :: & - deltaZ, & ! Layer thickness (km) - cloud_overlap_param, & ! Cloud-overlap parameter - precip_overlap_param ! Precipitation overlap parameter + deltaZ, & ! Layer thickness (km) + cloud_overlap_param, & ! Cloud-overlap parameter + precip_overlap_param ! Precipitation overlap parameter ! Outputs - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - integer,dimension(:,:),intent(out) :: & - mbota, & ! Vertical indices for cloud tops - mtopa ! Vertical indices for cloud bases - real(kind_phys), dimension(:,:), intent(out) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag + integer,dimension(:,:),intent(out) :: & + mbota, & ! Vertical indices for cloud tops + mtopa ! Vertical indices for cloud bases + real(kind_phys),dimension(:,:), intent(out) :: & + cldsa ! Fraction of clouds for low, middle, high, total and BL ! Local variables integer i,id,iCol,iLay,icld @@ -125,76 +125,6 @@ subroutine GFS_cloud_diagnostics_finalize() end subroutine GFS_cloud_diagnostics_finalize ! ###################################################################################### - ! Initialization routine for High/Mid/Low cloud diagnostics. + ! Subroutine hml_cloud_diagnostics_initialize is removed (refer to GFS_rrtmgp_setup.F90) ! ###################################################################################### - subroutine hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & - imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_mg, nLev, & - mpi_rank, sigmainit, errflg) - implicit none - ! Inputs - integer, intent(in) :: & - imp_physics, & ! Flag for MP scheme - imp_physics_fer_hires, & ! Flag for fer-hires scheme - imp_physics_gfdl, & ! Flag for gfdl scheme - imp_physics_thompson, & ! Flag for thompsonscheme - imp_physics_wsm6, & ! Flag for wsm6 scheme - imp_physics_zhao_carr, & ! Flag for zhao-carr scheme - imp_physics_zhao_carr_pdf, & ! Flag for zhao-carr+PDF scheme - imp_physics_mg ! Flag for MG scheme - integer, intent(in) :: & - nLev, & ! Number of vertical-layers - mpi_rank - real(kind_phys), dimension(:), intent(in) :: & - sigmainit - ! Outputs - integer, intent(out) :: & - errflg - - ! Local variables - integer :: iLay, kl - - ! Initialize error flag - errflg = 0 - - if (mpi_rank == 0) print *, VTAGCLD !print out version tag - - if ( icldflg == 0 ) then - print *,' - Diagnostic Cloud Method has been discontinued' - errflg = 1 - else - if (mpi_rank == 0) then - print *,' - Using Prognostic Cloud Method' - if (imp_physics == imp_physics_zhao_carr) then - print *,' --- Zhao/Carr/Sundqvist microphysics' - elseif (imp_physics == imp_physics_zhao_carr_pdf) then - print *,' --- zhao/carr/sundqvist + pdf cloud' - elseif (imp_physics == imp_physics_gfdl) then - print *,' --- GFDL Lin cloud microphysics' - elseif (imp_physics == imp_physics_thompson) then - print *,' --- Thompson cloud microphysics' - elseif (imp_physics == imp_physics_wsm6) then - print *,' --- WSM6 cloud microphysics' - elseif (imp_physics == imp_physics_mg) then - print *,' --- MG cloud microphysics' - elseif (imp_physics == imp_physics_fer_hires) then - print *,' --- Ferrier-Aligo cloud microphysics' - else - print *,' !!! ERROR in cloud microphysc specification!!!', & - ' imp_physics (NP3D) =',imp_physics - errflg = 1 - endif - endif - endif - - ! Compute the top of BL cld (llyr), which is the topmost non cld(low) layer for - ! stratiform (at or above lowest 0.1 of the atmosphere). - lab_do_k0 : do iLay = nLev, 2, -1 - kl = iLay - if (sigmainit(iLay) < 0.9e0) exit lab_do_k0 - enddo lab_do_k0 - llyr = kl - - return - end subroutine hml_cloud_diagnostics_initialize end module GFS_cloud_diagnostics diff --git a/physics/GFS_rrtmgp_cloud_overlap_pre.F90 b/physics/GFS_rrtmgp_cloud_overlap_pre.F90 index f85621d8f..2b632ea54 100644 --- a/physics/GFS_rrtmgp_cloud_overlap_pre.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap_pre.F90 @@ -4,7 +4,7 @@ module GFS_rrtmgp_cloud_overlap_pre use machine, only: kind_phys use radiation_tools, only: check_error_msg - use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exp + use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exper public GFS_rrtmgp_cloud_overlap_pre_init, GFS_rrtmgp_cloud_overlap_pre_run, GFS_rrtmgp_cloud_overlap_pre_finalize @@ -149,24 +149,25 @@ subroutine GFS_rrtmgp_cloud_overlap_pre_run(nCol, nLev, yearlen, doSWrad, doLWra ! Cloud overlap parameter ! if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then - call get_alpha_exp(nCol, nLev, deltaZc, de_lgth, cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc, & + de_lgth, cld_frac, cloud_overlap_param) else de_lgth(:) = 0. cloud_overlap_param(:,:) = 0. endif - ! For exponential random overlap... - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == iovr_exprand) then - do iLay = 1, nLev - do iCol = 1, nCol - if (cld_frac(iCol,iLay) .eq. 0. .and. cld_frac(iCol,iLay-1) .gt. 0.) then - cloud_overlap_param(iCol,iLay) = 0._kind_phys - endif - enddo - enddo - endif +! ! For exponential random overlap... +! ! Decorrelate layers when a clear layer follows a cloudy layer to enforce +! ! random correlation between non-adjacent blocks of cloudy layers +! if (iovr == iovr_exprand) then +! do iLay = 1, nLev +! do iCol = 1, nCol +! if (cld_frac(iCol,iLay) .eq. 0. .and. cld_frac(iCol,iLay-1) .gt. 0.) then +! cloud_overlap_param(iCol,iLay) = 0._kind_phys +! endif +! enddo +! enddo +! endif ! ! Compute precipitation overlap parameter (Hack. Using same as cloud for now) diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 index c6afd6ac0..664da7528 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.F90 +++ b/physics/GFS_rrtmgp_gfdlmp_pre.F90 @@ -5,7 +5,7 @@ module GFS_rrtmgp_gfdlmp_pre use machine, only: kind_phys use radiation_tools, only: check_error_msg - use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exp + use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exper use rrtmgp_lw_cloud_optics, only: radliq_lwr => radliq_lwrLW, radliq_upr => radliq_uprLW,& radice_lwr => radice_lwrLW, radice_upr => radice_uprLW diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index d518cb6e3..f7f657b50 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -5,7 +5,7 @@ module GFS_rrtmgp_setup use module_radiation_astronomy, only : sol_init, sol_update use module_radiation_aerosols, only : aer_init, aer_update use module_radiation_gases, only : gas_init, gas_update - use GFS_cloud_diagnostics, only : hml_cloud_diagnostics_initialize + ! use GFS_cloud_diagnostics, only : hml_cloud_diagnostics_initialize ! *NOTE* These parameters below are required radiation_****** modules. They are not ! directly used by the RRTMGP routines. use physparam, only : isolar, ictmflg, ico2flg, ioznflg, iaerflg, & @@ -130,10 +130,10 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, call sol_init ( me ) call aer_init ( levr, me ) call gas_init ( me ) - call hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & - imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_mg, levr, me, si,& - errflg) + !call hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & + ! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & + ! imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_mg, levr, me, si,& + ! errflg) if ( me == 0 ) then print *,' return from rad_initialize (GFS_rrtmgp_setup_init) - after calling radinit' diff --git a/physics/radiation_cloud_overlap.F90 b/physics/radiation_cloud_overlap.F90 index a94923ba5..87f2ebbf0 100644 --- a/physics/radiation_cloud_overlap.F90 +++ b/physics/radiation_cloud_overlap.F90 @@ -84,16 +84,22 @@ end subroutine cmp_dcorr_lgth_oreopoulos ! ###################################################################################### ! ! ###################################################################################### - subroutine get_alpha_exp(nCol, nLay, dzlay, dcorr_lgth, alpha) + subroutine get_alpha_exper(nCol, nLay, iovr, iovr_exprand, dzlay, & + dcorr_lgth, cld_frac, alpha) ! Inputs integer, intent(in) :: & nCol, & ! Number of horizontal grid points nLay ! Number of vertical grid points + integer, intent(in) :: & + iovr, & + iovr_exprand real(kind_phys), dimension(nCol), intent(in) :: & dcorr_lgth ! Decorrelation length (km) real(kind_phys), dimension(nCol,nLay), intent(in) :: & dzlay ! + real(kind_phys), dimension(:,:), intent(in) :: & + cld_frac ! Outputs real(kind_phys), dimension(nCol,nLay) :: & @@ -108,9 +114,22 @@ subroutine get_alpha_exp(nCol, nLay, dzlay, dcorr_lgth, alpha) alpha(iCol,iLay) = exp( -(dzlay(iCol,iLay)) / dcorr_lgth(iCol)) enddo enddo - + + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == iovr_exprand) then + do iLay = 2, nLay + do iCol = 1, nCol + if (cld_frac(iCol,iLay) == 0.0 .and. cld_frac(iCol,iLay-1) > 0.0) then + alpha(iCol,iLay) = 0.0 + endif + enddo + enddo + endif + return - end subroutine get_alpha_exp + end subroutine get_alpha_exper end module module_radiation_cloud_overlap diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 157350dff..4ee8b146a 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -43,17 +43,15 @@ ! cld_rwp, cld_rerain, cld_swp, cld_resnow, ! ! clds,mtop,mbot,de_lgth,alpha) ! ! ! -! internal/external accessable subroutines: ! +! internal/external accessable subroutines: ! ! 'progcld_zhao_carr' --- zhao/moorthi prognostic cloud scheme ! -! 'progcld2' --- inactive ! ! 'progcld_zhao_carr_pdf' --- zhao/moorthi prognostic cloud + pdfcld ! ! 'progcld_gfdl_lin' --- GFDL-Lin cloud microphysics ! -! 'progcld4o' --- inactive ! ! 'progcld_fer_hires' --- Ferrier-Aligo cloud microphysics ! ! 'progcld_thompson_wsm6' --- Thompson/wsm6 cloud microphysics (EMC) ! -! 'progclduni' --- MG cloud microphysics ! -! --- GFDL cloud microphysics (EMC) ! -! --- Thompson + MYNN PBL (or GF convection) ! +! 'progclduni' --- MG2/3 cloud microphysics ! +! (with/without SHOC) (EMC) ! +! also used by GFDL MP (EMC) ! ! 'progcld_thompson' --- Thompson MP (added by G. Thompson) ! ! 'gethml' --- get diagnostic hi, mid, low clouds ! ! ! @@ -104,8 +102,6 @@ ! apr 2004, yu-tai hou - separated calculation of the ! ! averaged h,m,l,bl cloud amounts from each of the cld schemes ! ! to become an shared individule subprogram 'gethml'. ! -! may 2004, yu-tai hou - rewritten ferrier's scheme as a ! -! separated program 'progcld2' in the cloud module. ! ! apr 2005, yu-tai hou - modified cloud array and module ! ! structures. ! ! dec 2008, yu-tai hou - changed low-cld calculation, ! @@ -114,7 +110,7 @@ ! adjusted for better agreement with observations. ! ! jan 2011, yu-tai hou - changed virtual temperature ! ! as input variable instead of originally computed inside the ! -! two prognostic cld schemes 'progcld_zhao_carr' and 'progcld2'. ! +! two prognostic cld schemes 'progcld_zhao_carr' ! ! aug 2012, yu-tai hou - modified subroutine cld_init ! ! to pass all fixed control variables at the start. and set ! ! their correponding internal module variables to be used by ! @@ -193,7 +189,7 @@ module module_radiation_clouds use module_microphysics, only : rsipath2 use module_iounitdef, only : NICLTUN use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, & - & get_alpha_exp + & get_alpha_exper use machine, only : kind_phys ! implicit none @@ -253,9 +249,9 @@ module module_radiation_clouds & 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & & 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/) - public progcld_zhao_carr, progcld2, progcld_zhao_carr_pdf, & + public progcld_zhao_carr, progcld_zhao_carr_pdf, & & progcld_gfdl_lin, progclduni, progcld_fer_hires, & - & cld_init, radiation_clouds_prop, progcld4o, & + & cld_init, radiation_clouds_prop, & & progcld_thompson_wsm6, progcld_thompson, cal_cldfra3, & & find_cloudLayers, adjust_cloudIce, adjust_cloudH2O, & & adjust_cloudFinal, gethml @@ -278,7 +274,7 @@ module module_radiation_clouds !!\n =10: MG microphysics !!\n =15: Ferrier-Aligo microphysics !!\param me print control flag -!>\section gen_cld_init cld_init General Algorithm +!>\section cld_init General Algorithm !! @{ subroutine cld_init & & ( si, NLAY, imp_physics, me ) ! --- inputs @@ -405,99 +401,7 @@ end subroutine cld_init !> \ingroup module_radiation_clouds !> Subroutine radiation_clouds_prop computes cloud related quantities !! for different cloud microphysics schemes. -!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) -!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) -!!\param tlyr (IX,NLAY), model layer mean temperature in K -!!\param tvly (IX,NLAY), model layer virtual temperature in K -!!\param qlyr (IX,NLAY), layer specific humidity in gm/gm -!!\param qstl (IX,NLAY), layer saturate humidity in gm/gm -!!\param rhly (IX,NLAY), layer relative humidity \f$ (=qlyr/qstl) \f$ -!!\param ccnd (IX,NLAY,ncndl), layer cloud condensate amount ! -!! water, ice, rain, snow (+ graupel) ! -!!\param ncndl number of layer cloud condensate types (max of 4) -!!\param cnvw (ix,nlay), layer convective cloud condensate -!!\param cnvc (ix,nlay), layer convective cloud cover -!!\param tracer1 (ix,nlay,1:ntrac-1), all tracers (except sphum) -!!\param xlat (IX), grid latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment -!!\param xlon (IX), grid longitude in radians (not used) -!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) -!!\param dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\param IX horizontal dimention -!!\param LM vertical layer for radiation calculation -!!\param NLAY adjusted vertical layer -!!\param NLP1 level dimensions -!!\param deltaq (ix,nlay), half total water distribution width -!!\param sup supersaturation -!!\param me print control flag -!!\param icloud cloud effect to the optical depth in radiation -!!\param kdt current time step index -!>\param ntrac number of tracers (Model%ntrac) -!>\param ntcw tracer index for cloud liquid water (Model%ntcw) -!>\param ntiw tracer index for cloud ice water (Model%ntiw) -!>\param ntrw tracer index for rain water (Model%ntrw) -!>\param ntsw tracer index for snow water (Model%ntsw) -!>\param ntgl tracer index for graupel (Model%ntgl) -!>\param ntclamt tracer index for cloud amount (Model%ntclamt) -!!\param imp_physics cloud microphysics scheme control flag -!!\param imp_physics_fer_hires Ferrier-Aligo microphysics (=15) -!!\param imp_physics_gfdl GFDL microphysics cloud (=11) -!!\param imp_physics_thompson Thompson microphysics (=8) -!!\param imp_physics_wsm6 WSM6 microphysics (=6) -!!\param imp_physics_zhao_carr Zhao-Carr/Sundqvist microphysics cloud (=99) -!!\param imp_physics_zhao_carr_pdf Zhao-Carr/Sundqvist microphysics cloud + PDF (=98) -!!\param imp_physics_mg MG microphysics (=10) -!!\param iovr_rand cloud-overlap: random -!!\param iovr_maxrand cloud-overlap: maximum random -!!\param iovr_max cloud-overlap: maximum -!!\param iovr_dcorr cloud-overlap: decorrelation length -!!\param iovr_exp cloud-overlap: exponential -!!\param iovr_exprand cloud-overlap: exponential random -!!\param idcor_con decorrelation-length: Use constant value -!!\param idcor_hogan choice for decorrelation-length -!!\param idcor_oreopoulos choice for decorrelation-length -!!\param imfdeepcnv flag for mass-flux deep convection scheme -!!\param imfdeepcnv_gf flag for scale- & aerosol-aware Grell-Freitas scheme (GSD) -!!\param do_mynnedmf flag for MYNN-EDMF -!!\param lgfdlmprad flag for GFDLMP radiation interaction -!!\param uni_cld logical, true for cloud fraction from shoc -!!\param lmfshal logical, mass-flux shallow convection scheme flag -!!\param lmfdeep2 logical, scale-aware mass-flux deep convection scheme flag -!!\param cldcov layer cloud fraction (used when uni_cld=.true.) -!!\param clouds1 layer total cloud fraction -!!\param effrl effective radius for liquid water -!!\param effri effective radius for ice water -!!\param effrr effective radius for rain water -!!\param effrs effective radius for snow water -!!\param effr_in logical, if .true. use input effective radii -!!\param effrl_inout eff. radius of cloud liquid water particle -!!\param effri_inout eff. radius of cloud ice water particle -!!\param effrs_inout effective radius of cloud snow particle -!!\param lwp_ex total liquid water path from explicit microphysics -!!\param iwp_ex total ice water path from explicit microphysics -!!\param lwp_fc total liquid water path from cloud fraction scheme -!!\param iwp_fc total ice water path from cloud fraction scheme -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) -!!\param gridkm grid length in km -!!\param cld_frac(:,:) - layer total cloud fraction -!!\param cld_lwp(:,:) - layer cloud liq water path \f$(g/m^2)\f$ -!!\param cld_reliq(:,:) - mean eff radius for liq cloud (micron) -!!\param cld_iwp(:,:) - layer cloud ice water path \f$(g/m^2)\f$ -!!\param cld_reice(:,:) - mean eff radius for ice cloud (micron) -!!\param cld_rwp(:,:) - layer rain drop water path (not assigned) -!!\param cld_rerain(:,:) - mean eff radius for rain drop (micron) -!!\param cld_swp(:,:) - layer snow flake water path (not assigned) -!!\param cld_resnow(:,:) - mean eff radius for snow flake (micron) -!!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl -!!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops -!!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases -!!\param de_lgth (IX), clouds decorrelation length (km) -!!\param alpha (IX,NLAY), alpha decorrelation parameter -!>\section gen_radiation_clouds_prop radiation_clouds_prop General Algorithm +!>\section radiation_clouds_prop General Algorithm !> @{ subroutine radiation_clouds_prop & & ( plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs: @@ -532,23 +436,23 @@ subroutine radiation_clouds_prop & ! and computes the low, mid, high, total and boundary layer cloud ! ! fractions and the vertical indices of low, mid, and high cloud ! ! top and base. the three vertical cloud domains are set up in the ! -! initial subroutine "radiation_clouds_init". ! +! initial subroutine "cld_init". ! ! ! ! usage: call radiation_clouds_prop ! ! ! ! subprograms called: ! ! ! ! 'progcld_zhao_carr' --- zhao/moorthi prognostic cloud scheme ! -! 'progcld2' --- inactive ! ! 'progcld_zhao_carr_pdf' --- zhao/moorthi prognostic cloud + pdfcld ! ! 'progcld_gfdl_lin' --- GFDL-Lin cloud microphysics ! -! 'progcld4o' --- inactive ! ! 'progcld_fer_hires' --- Ferrier-Aligo cloud microphysics ! ! 'progcld_thompson_wsm6' --- Thompson/wsm6 cloud microphysics (EMC) ! ! 'progclduni' --- MG cloud microphysics ! ! --- GFDL cloud microphysics (EMC) ! ! --- Thompson + MYNN PBL (or GF convection) ! ! 'progcld_thompson' --- Thompson MP (added by G. Thompson) ! +! 'gethml' --- get diagnostic hi, mid, low clouds ! +! ! ! attributes: ! ! language: fortran 90 ! ! machine: ibm-sp, sgi ! @@ -664,16 +568,6 @@ subroutine radiation_clouds_prop & ! lcnorm : control flag for in-cld condensate ! ! =t: normalize cloud condensate ! ! =f: not normalize cloud condensate ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! ! ! ! ==================== end of description ===================== ! implicit none @@ -730,7 +624,6 @@ subroutine radiation_clouds_prop & & lwp_ex, iwp_ex, lwp_fc, iwp_fc ! --- outputs -! real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds real (kind=kind_phys), dimension(:,:), intent(out) :: & & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & @@ -746,7 +639,6 @@ subroutine radiation_clouds_prop & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys), dimension(IX,NLAY,NF_CLDS) :: clouds real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 @@ -765,13 +657,20 @@ subroutine radiation_clouds_prop & & ncndl, lgfdlmprad, do_mynnedmf, imfdeepcnv, kdt end if - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo + do k = 1, NLAY + do i = 1, IX + cld_frac(i,k) = 0.0 + cld_lwp(i,k) = 0.0 + cld_reliq(i,k) = 0.0 + cld_iwp(i,k) = 0.0 + cld_reice(i,k) = 0.0 + cld_rwp(i,k) = 0.0 + cld_rerain(i,k) = 0.0 + cld_swp(i,k) = 0.0 + cld_resnow(i,k) = 0.0 enddo enddo + do k = 1, NLAY do i = 1, IX cldtot(i,k) = 0.0 @@ -790,7 +689,9 @@ subroutine radiation_clouds_prop & & effrl, effri, effrr, effrs, effr_in, & & dzlay, & & cldtot, cldcnv, & ! inout - & clouds) ! --- outputs + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) else call progcld_zhao_carr (plyr ,plvl, tlyr, tvly, qlyr, & ! --- inputs & qstl, rhly, ccnd(1:IX,1:NLAY,1), xlat, xlon, & @@ -799,7 +700,9 @@ subroutine radiation_clouds_prop & & cldcov, effrl, effri, effrr, effrs, effr_in, & & dzlay, & & cldtot, cldcnv, & ! inout - & clouds) ! --- outputs + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) endif elseif(imp_physics == imp_physics_zhao_carr_pdf) then ! zhao/moorthi's prognostic cloud+pdfcld @@ -809,7 +712,9 @@ subroutine radiation_clouds_prop & & xlat, xlon, slmsk, dz, delp, IX, NLAY, NLP1, & & deltaq, sup, kdt, me, dzlay, & & cldtot, cldcnv, & ! inout - & clouds) ! --- outputs + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) elseif (imp_physics == imp_physics_gfdl) then ! GFDL cloud scheme @@ -819,7 +724,9 @@ subroutine radiation_clouds_prop & & xlat, xlon, slmsk, cldcov, dz, delp, & & IX, NLAY, NLP1, dzlay, & & cldtot, cldcnv, & ! inout - & clouds) ! --- outputs + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) else call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, xlat, & ! --- inputs @@ -827,15 +734,9 @@ subroutine radiation_clouds_prop & & effrl, effri, effrr, effrs, effr_in, & & dzlay, & & cldtot, cldcnv, & ! inout - & clouds) ! --- outputs -! call progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs -! tracer1, xlat, xlon, slmsk, dz, delp, & -! ntrac-1, ntcw-1,ntiw-1,ntrw-1, & -! ntsw-1,ntgl-1,ntclamt-1, & -! IX,NLAY,NLP1, & -! dzlay, & -! cldtot, cldcnv, & ! inout -! clouds) ! --- outputs + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) endif @@ -855,7 +756,9 @@ subroutine radiation_clouds_prop & & effri_inout(:,:), effrs_inout(:,:), & & dzlay, & & cldtot, cldcnv, & ! inout - & clouds) ! --- outputs + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) elseif(imp_physics == imp_physics_thompson) then ! Thompson MP @@ -871,14 +774,16 @@ subroutine radiation_clouds_prop & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, gridkm, & & cldtot, cldcnv, & ! inout - & clouds) ! --- outputs + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) else !-- MYNN PBL or convective GF !-- use cloud fractions with SGS clouds do k=1,NLAY do i=1,IX - clouds(i,k,1) = clouds1(i,k) + cld_frac(i,k) = clouds1(i,k) enddo enddo @@ -886,11 +791,13 @@ subroutine radiation_clouds_prop & ! --- make sure that effr_in=.true. in the input.nml! call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs & xlat, xlon, slmsk, dz, delp, IX, NLAY, NLP1, & - & clouds(:,1:NLAY,1), & + & cld_frac, & & effrl, effri, effrr, effrs, effr_in , & & dzlay, & & cldtot, cldcnv, & ! inout - & clouds) ! --- outputs + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) endif else @@ -906,7 +813,9 @@ subroutine radiation_clouds_prop & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, gridkm, & & cldtot, cldcnv, & ! inout - & clouds) ! --- outputs + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) else call progcld_thompson_wsm6 (plyr,plvl,tlyr,qlyr,qstl, & ! --- inputs @@ -918,27 +827,14 @@ subroutine radiation_clouds_prop & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, & & cldtot, cldcnv, & ! inout - & clouds) ! --- outputs + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) endif endif ! MYNN PBL or GF endif ! end if_imp_physics - do k = 1, NLAY - do i = 1, IX - cld_frac(i,k) = clouds(i,k,1) - cld_lwp(i,k) = clouds(i,k,2) - cld_reliq(i,k) = clouds(i,k,3) - cld_iwp(i,k) = clouds(i,k,4) - cld_reice(i,k) = clouds(i,k,5) - cld_rwp(i,k) = clouds(i,k,6) - cld_rerain(i,k) = clouds(i,k,7) - cld_swp(i,k) = clouds(i,k,8) - cld_resnow(i,k) = clouds(i,k,9) - enddo - enddo - - !> - Compute SFC/low/middle/high cloud top pressure for each cloud !! domain for given latitude. ! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; @@ -968,28 +864,16 @@ subroutine radiation_clouds_prop & de_lgth(:) = decorr_con endif - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options + ! Call subroutine get_alpha_exper to define alpha parameter for exponential cloud overlap options if ( iovr == iovr_dcorr .or. iovr == iovr_exp & & .or. iovr == iovr_exprand) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) + call get_alpha_exper(ix, nLay, iovr, iovr_exprand, dzlay, & + & de_lgth, cld_frac, alpha) else de_lgth(:) = 0. alpha(:,:) = 0. endif - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == iovr_exprand) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - !> - Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. @@ -1015,44 +899,7 @@ end subroutine radiation_clouds_prop !> \ingroup module_radiation_clouds !> This subroutine computes cloud related quantities using !! zhao/moorthi's prognostic cloud microphysics scheme. -!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) -!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) -!!\param tlyr (IX,NLAY), model layer mean temperature in K -!!\param tvly (IX,NLAY), model layer virtual temperature in K -!!\param qlyr (IX,NLAY), layer specific humidity in gm/gm -!!\param qstl (IX,NLAY), layer saturate humidity in gm/gm -!!\param rhly (IX,NLAY), layer relative humidity \f$ (=qlyr/qstl) \f$ -!!\param clw (IX,NLAY), layer cloud condensate amount -!!\param xlat (IX), grid latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment -!!\param xlon (IX), grid longitude in radians (not used) -!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) -!!\param dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\param IX horizontal dimention -!!\param NLAY vertical layer -!!\param NLP1 level dimensions -!!\param uni_cld logical, true for cloud fraction from shoc -!!\param lmfshal logical, mass-flux shallow convection scheme flag -!!\param lmfdeep2 logical, scale-aware mass-flux deep convection scheme flag -!!\param cldcov layer cloud fraction (used when uni_cld=.true.) -!!\param effrl effective radius for liquid water -!!\param effri effective radius for ice water -!!\param effrr effective radius for rain water -!!\param effrs effective radius for snow water -!!\param effr_in logical, if .true. use input effective radii -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles -!!\n (:,:,1) - layer total cloud fraction -!!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ -!!\n (:,:,3) - mean eff radius for liq cloud (micron) -!!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ -!!\n (:,:,5) - mean eff radius for ice cloud (micron) -!!\n (:,:,6) - layer rain drop water path (not assigned) -!!\n (:,:,7) - mean eff radius for rain drop (micron) -!!\n (:,:,8) - layer snow flake water path (not assigned) -!!\n (:,:,9) - mean eff radius for snow flake (micron) -!>\section gen_progcld_zhao_carr progcld_zhao_carr General Algorithm +!>\section progcld_zhao_carr General Algorithm !> @{ subroutine progcld_zhao_carr & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: @@ -1060,7 +907,8 @@ subroutine progcld_zhao_carr & & uni_cld, lmfshal, lmfdeep2, cldcov, & & effrl,effri,effrr,effrs,effr_in, & & dzlay, cldtot, cldcnv, & - & clouds & ! --- outputs: + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! @@ -1107,19 +955,24 @@ subroutine progcld_zhao_carr & ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! effrl : effective radius for liquid water +! effri : effective radius for ice water +! effrr : effective radius for rain water +! effrs : effective radius for snow water +! effr_in : logical, if .true. use input effective radii ! dzlay(ix,nlay) : thickness between model layer centers (km) ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -1150,8 +1003,11 @@ subroutine progcld_zhao_carr & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds +! --- inputs/outputs + + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & @@ -1257,55 +1113,16 @@ subroutine progcld_zhao_carr & !> - Compute layer cloud fraction. - clwmin = 0.0 - if (.not. lmfshal) then - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 -! tem1 = 1000.0 / tem1 - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo + if (.not. lmfshal) then + call cloud_fraction_XuRandall & + & ( IX, NLAY, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs else - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) -! - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - if (lmfdeep2) then - tem1 = xrc3 / tem1 - else - tem1 = 100.0 / tem1 - endif -! - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - endif + call cloud_fraction_mass_flx_1 & + & ( IX, NLAY, lmfdeep2, xrc3, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) + endif endif ! if (uni_cld) then @@ -1367,15 +1184,15 @@ subroutine progcld_zhao_carr & ! do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) -! clouds(i,k,6) = 0.0 - clouds(i,k,7) = rer(i,k) -! clouds(i,k,8) = 0.0 - clouds(i,k,9) = res(i,k) + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) +! cld_rwp(i,k) = 0.0 + cld_rerain(i,k) = rer(i,k) +! cld_swp(i,k) = 0.0 + cld_resnow(i,k) = res(i,k) enddo enddo ! @@ -1384,67 +1201,36 @@ subroutine progcld_zhao_carr & end subroutine progcld_zhao_carr !----------------------------------- !> @} +!----------------------------------- !> \ingroup module_radiation_clouds -!> This subroutine computes cloud related quantities using Ferrier's -!! prognostic cloud microphysics scheme. -!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) -!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) -!!\param tlyr (IX,NLAY), model layer mean temperature in K -!!\param tvly (IX,NLAY), model layer virtual temperature in K -!!\param qlyr (IX,NLAY), layer specific humidity in gm/gm -!!\param qstl (IX,NLAY), layer saturate humidity in gm/gm -!!\param rhly (IX,NLAY), layer relative humidity (=qlyr/qstl) -!!\param clw (IX,NLAY), layer cloud condensate amount -!!\param f_ice (IX,NLAY), fraction of layer cloud ice (ferrier micro-phys) -!!\param f_rain (IX,NLAY), fraction of layer rain water (ferrier micro-phys) -!!\param r_rime (IX,NLAY), mass ratio of total ice to unrimed ice (>=1) -!!\param flgmin (IX), minimum large ice fraction -!!\param xlat (IX), grid latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment -!!\param xlon (IX), grid longitude in radians (not used) -!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) -!!\param dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\param IX horizontal dimention -!!\param NLAY,NLP1 vertical layer/level dimensions -!!\param lmfshal flag for mass-flux shallow convection scheme in the cloud fraction calculation -!!\param lmfdeep2 flag for mass-flux deep convection scheme in the cloud fraction calculation -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles -!!\n (:,:,1) - layer total cloud fraction -!!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ -!!\n (:,:,3) - mean eff radius for liq cloud (micron) -!!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ -!!\n (:,:,5) - mean eff radius for ice cloud (micron) -!!\n (:,:,6) - layer rain drop water path \f$(g/m^2)\f$ -!!\n (:,:,7) - mean eff radius for rain drop (micron) -!!\n (:,:,8) - layer snow flake water path \f$(g/m^2)\f$ -!!\n (:,:,9) - mean eff radius for snow flake (micron) -!>\section gen_progcld2 progcld2 General Algorithm for the F-A MP scheme -!> @{ - subroutine progcld2 & - & ( plyr,plvl,tlyr,qlyr,qstl,rhly,tvly,clw, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, & - & ntrac, ntcw, ntiw, ntrw, & - & IX, NLAY, NLP1, lmfshal, lmfdeep2, & +!> This subroutine computes cloud related quantities using +!! zhao/moorthi's prognostic cloud microphysics scheme + pdfcld. +!>\section progcld_zhao_carr_pdf General Algorithm +!! @{ + subroutine progcld_zhao_carr_pdf & + & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: + & xlat,xlon,slmsk, dz, delp, & + & ix, nlay, nlp1, & + & deltaq,sup,kdt,me, & & dzlay, cldtot, cldcnv, & - & clouds & ! --- outputs: + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld2 computes cloud related quantities using ! -! WSM6 cloud microphysics scheme. ! +! subprogram: progcld_zhao_carr_pdf computes cloud related quantities using ! +! zhao/moorthi's prognostic cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! -! condensates, ! +! condensates, calculates liquid/ice cloud droplet effective radius, ! ! and computes the low, mid, high, total and boundary layer cloud ! ! fractions and the vertical indices of low, mid, and high cloud ! ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld2 ! +! usage: call progcld_zhao_carr_pdf ! ! ! ! subprograms called: gethml ! ! ! @@ -1453,49 +1239,49 @@ subroutine progcld2 & ! machine: ibm-sp, sgi ! ! ! ! ! -! ==================== definition of variables ==================== ! +! ==================== defination of variables ==================== ! ! ! ! input variables: ! -! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! -! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! -! tlyr (IX,NLAY) : model layer mean temperature in k ! -! tvly (IX,NLAY) : model layer virtual temperature in k ! -! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! -! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! -! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! -! clw (IX,NLAY) : layer cloud condensate amount ! -! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! plyr (ix,nlay) : model layer mean pressure in mb (100pa) ! +! plvl (ix,nlp1) : model level pressure in mb (100pa) ! +! tlyr (ix,nlay) : model layer mean temperature in k ! +! tvly (ix,nlay) : model layer virtual temperature in k ! +! qlyr (ix,nlay) : layer specific humidity in gm/gm ! +! qstl (ix,nlay) : layer saturate humidity in gm/gm ! +! rhly (ix,nlay) : layer relative humidity (=qlyr/qstl) ! +! clw (ix,nlay) : layer cloud condensate amount ! +! xlat (ix) : grid latitude in radians, default to pi/2 -> -pi/2! ! range, otherwise see in-line comment ! -! xlon (IX) : grid longitude in radians (not used) ! -! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! xlon (ix) : grid longitude in radians (not used) ! +! slmsk (ix) : sea/land mask array (sea:0,land:1,sea-ice:2) ! ! dz (ix,nlay) : layer thickness (km) ! ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! IX : horizontal dimention ! -! NLAY,NLP1 : vertical layer/level dimensions ! -! lmfshal : logical - true for mass flux shallow convection ! -! lmfdeep2 : logical - true for mass flux deep convection ! +! ix : horizontal dimention ! +! nlay,nlp1 : vertical layer/level dimensions ! +! cnvw (ix,nlay) : layer convective cloud condensate ! +! cnvc (ix,nlay) : layer convective cloud cover ! +! deltaq(ix,nlay) : half total water distribution width ! +! sup : supersaturation ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! ! =0: index from toa to surface ! ! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! +! lcrick : control flag for eliminating crick ! +! =t: apply layer smoothing to eliminate crick ! ! =f: do not apply layer smoothing ! ! lcnorm : control flag for in-cld condensate ! ! =t: normalize cloud condensate ! @@ -1506,24 +1292,29 @@ subroutine progcld2 & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 - integer, intent(in) :: ntrac, ntcw, ntiw, ntrw - - logical, intent(in) :: lmfshal, lmfdeep2 - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, qlyr, qstl, rhly, tvly, dz, delp, dzlay + integer, intent(in) :: ix, nlay, nlp1,kdt - real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, tvly, qlyr, qstl, rhly, clw, dz, delp, dzlay +! & tlyr, tvly, qlyr, qstl, rhly, clw, cnvw, cnvc +! real (kind=kind_phys), dimension(:,:), intent(in) :: deltaq + real (kind=kind_phys), dimension(:,:) :: deltaq, cnvw, cnvc + real (kind=kind_phys) qtmp,qsc,rhs + real (kind=kind_phys), intent(in) :: sup + real (kind=kind_phys), parameter :: epsq = 1.0e-12 - real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk + integer :: me -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds +! --- inputs/outputs + + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & + real (kind=kind_phys), dimension(ix,nlay) :: cldtot, cldcnv, & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & @@ -1531,386 +1322,73 @@ subroutine progcld2 & integer :: i, k, id, nf -! --- constant values -! real (kind=kind_phys), parameter :: xrc3 = 200. - real (kind=kind_phys), parameter :: xrc3 = 100. - ! !===> ... begin here ! - do k = 1, NLAY - do i = 1, IX + do k = 1, nlay + do i = 1, ix cldtot(i,k) = 0.0 cldcnv(i,k) = 0.0 cwp (i,k) = 0.0 cip (i,k) = 0.0 crp (i,k) = 0.0 csp (i,k) = 0.0 - rew (i,k) = reliq_def - rei (i,k) = reice_def + rew (i,k) = reliq_def ! default liq radius to 10 micron + rei (i,k) = reice_def ! default ice radius to 50 micron rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = rsnow_def + res (i,k) = rsnow_def ! default snow radius to 250 micron + tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) clwf(i,k) = 0.0 enddo enddo ! - - do k = 1, NLAY - do i = 1, IX - clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) + if ( lcrick ) then + do i = 1, ix + clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) + clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) + enddo + do k = 2, nlay-1 + do i = 1, ix + clwf(i,k) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) enddo - enddo - -!> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . + enddo + else + do k = 1, nlay + do i = 1, ix + clwf(i,k) = clw(i,k) + enddo + enddo + endif - do k = 1, NLAY - do i = 1, IX - cwp(i,k) = max(0.0, clw(i,k,ntcw) * gfac * delp(i,k)) - cip(i,k) = max(0.0, clw(i,k,ntiw) * gfac * delp(i,k)) - crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) - csp(i,k) = 0.0 + if(kdt==1) then + do k = 1, nlay + do i = 1, ix + deltaq(i,k) = (1.-0.95)*qstl(i,k) enddo - enddo + enddo + endif -!> - Compute cloud ice effective radii +!> -# Calculate liquid/ice condensate path in \f$ g/m^2 \f$ - do k = 1, NLAY - do i = 1, IX - tem2 = tlyr(i,k) - con_ttp + do k = 1, nlay + do i = 1, ix + clwt = max(0.0,(clwf(i,k)+cnvw(i,k))) * gfac * delp(i,k) + cip(i,k) = clwt * tem2d(i,k) + cwp(i,k) = clwt - cip(i,k) + enddo + enddo - if (cip(i,k) > 0.0) then - tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) +!> -# Calculate effective liquid cloud droplet radius over land. - if (tem2 < -50.0) then - rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem2 < -40.0) then - rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem2 < -30.0) then - rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 - else - rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 - endif - rei(i,k) = max(10.0, min(rei(i,k), 150.0)) - endif + do i = 1, ix + if (nint(slmsk(i)) == 1) then + do k = 1, nlay + rew(i,k) = 5.0 + 5.0 * tem2d(i,k) enddo + endif enddo -!> - Calculate layer cloud fraction. - - clwmin = 0.0 - if (.not. lmfshal) then - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 - -! tem1 = 1000.0 / tem1 - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - else - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) -! - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - if (lmfdeep2) then - tem1 = xrc3 / tem1 - else - tem1 = 100.0 / tem1 - endif -! - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - endif - - do k = 1, NLAY - do i = 1, IX - if (cldtot(i,k) < climit) then - cldtot(i,k) = 0.0 - cwp(i,k) = 0.0 - cip(i,k) = 0.0 - crp(i,k) = 0.0 - csp(i,k) = 0.0 - endif - enddo - enddo - - if ( lcnorm ) then - do k = 1, NLAY - do i = 1, IX - if (cldtot(i,k) >= climit) then - tem1 = 1.0 / max(climit2, cldtot(i,k)) - cwp(i,k) = cwp(i,k) * tem1 - cip(i,k) = cip(i,k) * tem1 - crp(i,k) = crp(i,k) * tem1 - csp(i,k) = csp(i,k) * tem1 - endif - enddo - enddo - endif - -! - do k = 1, NLAY - do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) ! added for Thompson - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) ! added for Thompson - clouds(i,k,9) = res(i,k) - enddo - enddo -! - return -!................................... - end subroutine progcld2 -!................................... - -!> @} -!----------------------------------- - -!> \ingroup module_radiation_clouds -!> This subroutine computes cloud related quantities using -!! zhao/moorthi's prognostic cloud microphysics scheme + pdfcld. -!!\param plyr (ix,nlay), model layer mean pressure in mb (100pa) -!!\param plvl (ix,nlp1), model level pressure in mb (100pa) -!!\param tlyr (ix,nlay), model layer mean temperature in K -!!\param tvly (ix,nlay), model layer virtual temperature in K -!!\param qlyr (ix,nlay), layer specific humidity in gm/gm -!!\param qstl (ix,nlay), layer saturate humidity in gm/gm -!!\param rhly (ix,nlay), layer relative humidity (=qlyr/qstl) -!!\param clw (ix,nlay), layer cloud condensate amount -!!\param cnvw (ix,nlay), layer convective cloud condensate -!!\param cnvc (ix,nlay), layer convective cloud cover -!!\param xlat (ix), grid latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment -!!\param xlon (ix), grid longitude in radians (not used) -!!\param slmsk (ix), sea/land mask array (sea:0,land:1,sea-ice:2) -!!\param dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\param ix horizontal dimention -!!\param nlay,nlp1 vertical layer/level dimensions -!!\param deltaq (ix,nlay), half total water distribution width -!!\param sup supersaturation -!!\param kdt -!!\param me print control flag -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param clouds (ix,nlay,nf_clds), cloud profiles -!!\n (:,:,1) - layer total cloud fraction -!!\n (:,:,2) - layer cloud liq water path (g/m**2) -!!\n (:,:,3) - mean eff radius for liq cloud (micron) -!!\n (:,:,4) - layer cloud ice water path (g/m**2) -!!\n (:,:,5) - mean eff radius for ice cloud (micron) -!!\n (:,:,6) - layer rain drop water path not assigned -!!\n (:,:,7) - mean eff radius for rain drop (micron) -!!\n (:,:,8) - layer snow flake water path not assigned -!!\n (:,:,9) - mean eff radius for snow flake(micron) -!>\section gen_progcld_zhao_carr_pdf progcld_zhao_carr_pdf General Algorithm -!! @{ - subroutine progcld_zhao_carr_pdf & - & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: - & xlat,xlon,slmsk, dz, delp, & - & ix, nlay, nlp1, & - & deltaq,sup,kdt,me, & - & dzlay, cldtot, cldcnv, & - & clouds & ! --- outputs: - & ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: progcld_zhao_carr_pdf computes cloud related quantities using ! -! zhao/moorthi's prognostic cloud microphysics scheme. ! -! ! -! abstract: this program computes cloud fractions from cloud ! -! condensates, calculates liquid/ice cloud droplet effective radius, ! -! and computes the low, mid, high, total and boundary layer cloud ! -! fractions and the vertical indices of low, mid, and high cloud ! -! top and base. the three vertical cloud domains are set up in the ! -! initial subroutine "cld_init". ! -! ! -! usage: call progcld_zhao_carr_pdf ! -! ! -! subprograms called: gethml ! -! ! -! attributes: ! -! language: fortran 90 ! -! machine: ibm-sp, sgi ! -! ! -! ! -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! plyr (ix,nlay) : model layer mean pressure in mb (100pa) ! -! plvl (ix,nlp1) : model level pressure in mb (100pa) ! -! tlyr (ix,nlay) : model layer mean temperature in k ! -! tvly (ix,nlay) : model layer virtual temperature in k ! -! qlyr (ix,nlay) : layer specific humidity in gm/gm ! -! qstl (ix,nlay) : layer saturate humidity in gm/gm ! -! rhly (ix,nlay) : layer relative humidity (=qlyr/qstl) ! -! clw (ix,nlay) : layer cloud condensate amount ! -! xlat (ix) : grid latitude in radians, default to pi/2 -> -pi/2! -! range, otherwise see in-line comment ! -! xlon (ix) : grid longitude in radians (not used) ! -! slmsk (ix) : sea/land mask array (sea:0,land:1,sea-ice:2) ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! ix : horizontal dimention ! -! nlay,nlp1 : vertical layer/level dimensions ! -! cnvw (ix,nlay) : layer convective cloud condensate ! -! cnvc (ix,nlay) : layer convective cloud cover ! -! deltaq(ix,nlay) : half total water distribution width ! -! sup : supersaturation ! -! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! ! -! output variables: ! -! clouds(ix,nlay,nf_clds) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lcrick : control flag for eliminating crick ! -! =t: apply layer smoothing to eliminate crick ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! -! ==================== end of description ===================== ! -! - implicit none - -! --- inputs - integer, intent(in) :: ix, nlay, nlp1,kdt - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, clw, dz, delp, dzlay -! & tlyr, tvly, qlyr, qstl, rhly, clw, cnvw, cnvc -! real (kind=kind_phys), dimension(:,:), intent(in) :: deltaq - real (kind=kind_phys), dimension(:,:) :: deltaq, cnvw, cnvc - real (kind=kind_phys) qtmp,qsc,rhs - real (kind=kind_phys), intent(in) :: sup - real (kind=kind_phys), parameter :: epsq = 1.0e-12 - - real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & - & slmsk - integer :: me - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - -! --- local variables: - real (kind=kind_phys), dimension(ix,nlay) :: cldtot, cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & - & tem1, tem2, tem3 - - integer :: i, k, id, nf - -! -!===> ... begin here -! - do k = 1, nlay - do i = 1, ix - cldtot(i,k) = 0.0 - cldcnv(i,k) = 0.0 - cwp (i,k) = 0.0 - cip (i,k) = 0.0 - crp (i,k) = 0.0 - csp (i,k) = 0.0 - rew (i,k) = reliq_def ! default liq radius to 10 micron - rei (i,k) = reice_def ! default ice radius to 50 micron - rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = rsnow_def ! default snow radius to 250 micron - tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) - clwf(i,k) = 0.0 - enddo - enddo -! - if ( lcrick ) then - do i = 1, ix - clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) - clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) - enddo - do k = 2, nlay-1 - do i = 1, ix - clwf(i,k) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) - enddo - enddo - else - do k = 1, nlay - do i = 1, ix - clwf(i,k) = clw(i,k) - enddo - enddo - endif - - if(kdt==1) then - do k = 1, nlay - do i = 1, ix - deltaq(i,k) = (1.-0.95)*qstl(i,k) - enddo - enddo - endif - -!> -# Calculate liquid/ice condensate path in \f$ g/m^2 \f$ - - do k = 1, nlay - do i = 1, ix - clwt = max(0.0,(clwf(i,k)+cnvw(i,k))) * gfac * delp(i,k) - cip(i,k) = clwt * tem2d(i,k) - cwp(i,k) = clwt - cip(i,k) - enddo - enddo - -!> -# Calculate effective liquid cloud droplet radius over land. - - do i = 1, ix - if (nint(slmsk(i)) == 1) then - do k = 1, nlay - rew(i,k) = 5.0 + 5.0 * tem2d(i,k) - enddo - endif - enddo - -!> -# Calculate layer cloud fraction. +!> -# Calculate layer cloud fraction. do k = 1, nlay do i = 1, ix @@ -2007,17 +1485,17 @@ subroutine progcld_zhao_carr_pdf & enddo ! - do k = 1, nlay - do i = 1, ix - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) -! clouds(i,k,6) = 0.0 - clouds(i,k,7) = rer(i,k) -! clouds(i,k,8) = 0.0 - clouds(i,k,9) = res(i,k) + do k = 1, NLAY + do i = 1, IX + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) +! cld_rwp(i,k) = 0.0 + cld_rerain(i,k) = rer(i,k) +! cld_swp(i,k) = 0.0 + cld_resnow(i,k) = res(i,k) enddo enddo ! @@ -2032,45 +1510,15 @@ end subroutine progcld_zhao_carr_pdf !> \ingroup module_radiation_clouds !> This subroutine computes cloud related quantities using !! GFDL Lin MP prognostic cloud microphysics scheme. -!!\param plyr (ix,nlay), model layer mean pressure in mb (100Pa) -!!\param plvl (ix,nlp1), model level pressure in mb (100Pa) -!!\param tlyr (ix,nlay), model layer mean temperature in K -!!\param tvly (ix,nlay), model layer virtual temperature in K -!!\param qlyr (ix,nlay), layer specific humidity in gm/gm -!!\param qstl (ix,nlay), layer saturate humidity in gm/gm -!!\param rhly (ix,nlay), layer relative humidity (=qlyr/qstl) -!!\param clw (ix,nlay), layer cloud condensate amount -!!\param cnvw (ix,nlay), layer convective cloud condensate -!!\param cnvc (ix,nlay), layer convective cloud cover -!!\param xlat (ix), grid latitude in radians, default to pi/2 -> -pi/2 -!! range, otherwise see in-line comment -!!\param xlon (ix), grid longitude in radians (not used) -!!\param slmsk (ix), sea/land mask array (sea:0, land:1, sea-ice:2) -!!\param cldtot (ix,nlay), layer total cloud fraction -!!\param dz (ix,nlay), layer thickness (km) -!!\param delp (ix,nlay), model layer pressure thickness in mb (100Pa) -!!\param ix horizontal dimension -!!\param nlay vertical layer dimension -!!\param nlp1 vertical level dimension -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param clouds (ix,nlay,nf_clds), cloud profiles -!!\n clouds(:,:,1) - layer total cloud fraction -!!\n clouds(:,:,2) - layer cloud liquid water path (\f$g m^{-2}\f$) -!!\n clouds(:,:,3) - mean effective radius for liquid cloud (micron) -!!\n clouds(:,:,4) - layer cloud ice water path (\f$g m^{-2}\f$) -!!\n clouds(:,:,5) - mean effective radius for ice cloud (micron) -!!\n clouds(:,:,6) - layer rain drop water path (\f$g m^{-2}\f$) (not assigned) -!!\n clouds(:,:,7) - mean effective radius for rain drop (micron) -!!\n clouds(:,:,8) - layer snow flake water path (not assigned) (\f$g m^{-2}\f$) (not assigned) -!!\n clouds(:,:,9) - mean effective radius for snow flake (micron) -!>\section gen_progcld_gfdl_lin progcld_gfdl_lin General Algorithm +!>\section progcld_gfdl_lin General Algorithm !! @{ subroutine progcld_gfdl_lin & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: & xlat,xlon,slmsk,cldtot, dz, delp, & & IX, NLAY, NLP1, & & dzlay, cldtot1, cldcnv, & - & clouds & ! --- outputs: + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! @@ -2118,16 +1566,16 @@ subroutine progcld_gfdl_lin & ! dzlay(ix,nlay) : thickness between model layer centers (km) ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -2155,315 +1603,27 @@ subroutine progcld_gfdl_lin & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot1 -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - -! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & - & tem1, tem2, tem3 - - integer :: i, k, id, nf - -! -!===> ... begin here -! -!> - Assign liquid/ice/rain/snow cloud doplet effective radius as default value. - do k = 1, NLAY - do i = 1, IX - cldcnv(i,k) = 0.0 - cwp (i,k) = 0.0 - cip (i,k) = 0.0 - crp (i,k) = 0.0 - csp (i,k) = 0.0 - rew (i,k) = reliq_def !< default liq radius to 10 micron - rei (i,k) = reice_def !< default ice radius to 50 micron - rer (i,k) = rrain_def !< default rain radius to 1000 micron - res (i,k) = rsnow_def !< default snow radius to 250 micron - tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) - clwf(i,k) = 0.0 - enddo - enddo -! - if ( lcrick ) then - do i = 1, IX - clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) - clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) - enddo - do k = 2, NLAY-1 - do i = 1, IX - clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) - enddo - enddo - else - do k = 1, NLAY - do i = 1, IX - clwf(i,k) = clw(i,k) - enddo - enddo - endif - -!> - Compute liquid/ice condensate path in \f$g m^{-2}\f$. - - do k = 1, NLAY - do i = 1, IX - clwt = max(0.0,(clwf(i,k)+cnvw(i,k))) * gfac * delp(i,k) - cip(i,k) = clwt * tem2d(i,k) - cwp(i,k) = clwt - cip(i,k) - enddo - enddo - -!> - Compute effective liquid cloud droplet radius over land. - - do i = 1, IX - if (nint(slmsk(i)) == 1) then - do k = 1, NLAY - rew(i,k) = 5.0 + 5.0 * tem2d(i,k) - enddo - endif - enddo - - do k = 1, NLAY - do i = 1, IX - if (cldtot(i,k) < climit) then - cwp(i,k) = 0.0 - cip(i,k) = 0.0 - crp(i,k) = 0.0 - csp(i,k) = 0.0 - endif - enddo - enddo - - if ( lcnorm ) then - do k = 1, NLAY - do i = 1, IX - if (cldtot(i,k) >= climit) then - tem1 = 1.0 / max(climit2, cldtot(i,k)) - cwp(i,k) = cwp(i,k) * tem1 - cip(i,k) = cip(i,k) * tem1 - crp(i,k) = crp(i,k) * tem1 - csp(i,k) = csp(i,k) * tem1 - endif - enddo - enddo - endif - -!> - Compute effective ice cloud droplet radius in Heymsfield and McFarquhar (1996) -!! \cite heymsfield_and_mcfarquhar_1996 . - - do k = 1, NLAY - do i = 1, IX - tem2 = tlyr(i,k) - con_ttp - - if (cip(i,k) > 0.0) then - tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) - - if (tem2 < -50.0) then - rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem2 < -40.0) then - rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem2 < -30.0) then - rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 - else - rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 - endif -! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) -! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) - rei(i,k) = max(10.0, min(rei(i,k), 150.0)) -! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) - endif - enddo - enddo - - do k = 1, NLAY - do i = 1, IX - cldtot1(i,k) = cldtot(i,k) - enddo - enddo - -! - do k = 1, NLAY - do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) -! clouds(i,k,6) = 0.0 - clouds(i,k,7) = rer(i,k) -! clouds(i,k,8) = 0.0 - clouds(i,k,9) = res(i,k) - enddo - enddo -! - return -!................................... - end subroutine progcld_gfdl_lin -!! @} -!----------------------------------- - -!----------------------------------- -!> \ingroup module_radiation_clouds -!! This subroutine computes cloud related quantities using GFDL Lin MP -!! prognostic cloud microphysics scheme. Moist species from MP are fed -!! into the corresponding arrays for calculation of cloud fractions. -!! -!>\param plyr (ix,nlay), model layer mean pressure in mb (100Pa) -!>\param plvl (ix,nlp1), model level pressure in mb (100Pa) -!>\param tlyr (ix,nlay), model layer mean temperature in K -!>\param tvly (ix,nlay), model layer virtual temperature in K -!>\param qlyr (ix,nlay), layer specific humidity in \f$gm gm^{-1}\f$ -!>\param qstl (ix,nlay), layer saturate humidity in \f$gm gm^{-1}\f$ -!>\param rhly (ix,nlay), layer relative humidity (=qlyr/qstl) -!>\param clw (ix,nlay,ntrac), layer cloud condensate amount -!>\param xlat (ix), grid latitude in radians, default to pi/2->-pi/2 -!! range, otherwise see in-line comment -!>\param xlon (ix), grid longitude in radians (not used) -!>\param slmsk (ix), sea/land mask array (sea:0, land:1, sea-ice:2) -!>\param dz layer thickness (km) -!>\param delp model layer pressure thickness in mb (100Pa) -!>\param ntrac number of tracers minus one (Model%ntrac-1) -!>\param ntcw tracer index for cloud liquid water minus one (Model%ntcw-1) -!>\param ntiw tracer index for cloud ice water minus one (Model%ntiw-1) -!>\param ntrw tracer index for rain water minus one (Model%ntrw-1) -!>\param ntsw tracer index for snow water minus one (Model%ntsw-1) -!>\param ntgl tracer index for graupel minus one (Model%ntgl-1) -!>\param ntclamt tracer index for cloud amount minus one (Model%ntclamt-1) -!>\param ix horizontal dimension -!>\param nlay vertical layer dimension -!>\param nlp1 vertical level dimension -!!\param dzlay(ix,nlay) distance between model layer centers -!>\param clouds (ix,nlay,nf_clds), cloud profiles -!!\n clouds(:,:,1) - layer totoal cloud fraction -!!\n clouds(:,:,2) - layer cloud liquid water path (\f$g m^{-2}\f$) -!!\n clouds(:,:,3) - mean effective radius for liquid cloud (micron) -!!\n clouds(:,:,4) - layer cloud ice water path (\f$g m^{-2}\f$) -!!\n clouds(:,:,5) - mean effective radius for ice cloud (micron) -!!\n clouds(:,:,6) - layer rain dropwater path (\f$g m^{-2}\f$) -!!\n clouds(:,:,7) - mean effective radius for rain drop (micron) -!!\n clouds(:,:,8) - layer snow flake water path (\f$g m^{-2}\f$) -!!\n clouds(:,:,9) - mean effective radius for snow flake (micron) -!>\section gen_progcld4o progcld4o General Algorithm -!! @{ - subroutine progcld4o & - & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: - & xlat,xlon,slmsk, dz, delp, & - & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl,ntclamt, & - & IX, NLAY, NLP1, & - & dzlay, cldtot, cldcnv, & - & clouds & ! --- outputs: - & ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: progcld4o computes cloud related quantities using ! -! GFDL Lin MP prognostic cloud microphysics scheme. Moist species ! -! from MP are fed into the corresponding arrays for calcuation of ! -! ! -! abstract: this program computes cloud fractions from cloud ! -! condensates, calculates liquid/ice cloud droplet effective radius, ! -! and computes the low, mid, high, total and boundary layer cloud ! -! fractions and the vertical indices of low, mid, and high cloud ! -! top and base. the three vertical cloud domains are set up in the ! -! initial subroutine "cld_init". ! -! ! -! usage: call progcld4o ! -! ! -! subprograms called: gethml ! -! ! -! attributes: ! -! language: fortran 90 ! -! machine: ibm-sp, sgi ! -! ! -! ! -! ==================== definition of variables ==================== ! -! ! -! input variables: ! -! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! -! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! -! tlyr (IX,NLAY) : model layer mean temperature in k ! -! tvly (IX,NLAY) : model layer virtual temperature in k ! -! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! -! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! -! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! -! clw (IX,NLAY,NTRAC) : layer cloud condensate amount ! -! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! -! range, otherwise see in-line comment ! -! xlon (IX) : grid longitude in radians (not used) ! -! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! IX : horizontal dimention ! -! NLAY,NLP1 : vertical layer/level dimensions ! -! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! ! -! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter -! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lsashal : control flag for shallow convection ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! -! ==================== end of description ===================== ! -! - implicit none - -! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 - integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, & - & ntclamt - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, delp, dz, dzlay - - - real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw - real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & - & slmsk - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot1 + +! --- inputs/outputs + + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, tem2d + & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - real (kind=kind_phys), dimension(IX,NLAY) :: cldtot integer :: i, k, id, nf ! !===> ... begin here ! -!> - Assign liquid/ice/rain/snow cloud droplet effective radius as default value. +!> - Assign liquid/ice/rain/snow cloud doplet effective radius as default value. do k = 1, NLAY do i = 1, IX cldcnv(i,k) = 0.0 @@ -2471,24 +1631,40 @@ subroutine progcld4o & cip (i,k) = 0.0 crp (i,k) = 0.0 csp (i,k) = 0.0 - rew (i,k) = reliq_def ! default liq radius to 10 micron - rei (i,k) = reice_def ! default ice radius to 50 micron - rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = rsnow_def ! default snow radius to 250 micron + rew (i,k) = reliq_def !< default liq radius to 10 micron + rei (i,k) = reice_def !< default ice radius to 50 micron + rer (i,k) = rrain_def !< default rain radius to 1000 micron + res (i,k) = rsnow_def !< default snow radius to 250 micron tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) - cldtot(i,k) = clw(i,k,ntclamt) + clwf(i,k) = 0.0 enddo enddo +! + if ( lcrick ) then + do i = 1, IX + clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) + clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) + enddo + do k = 2, NLAY-1 + do i = 1, IX + clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) + enddo + enddo + else + do k = 1, NLAY + do i = 1, IX + clwf(i,k) = clw(i,k) + enddo + enddo + endif -!> - Compute liquid/ice condensate path in \f$g m^{-2}\f$ +!> - Compute liquid/ice condensate path in \f$g m^{-2}\f$. do k = 1, NLAY do i = 1, IX - cwp(i,k) = max(0.0, clw(i,k,ntcw) * gfac * delp(i,k)) - cip(i,k) = max(0.0, clw(i,k,ntiw) * gfac * delp(i,k)) - crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) - csp(i,k) = max(0.0, (clw(i,k,ntsw)+clw(i,k,ntgl)) * & - & gfac * delp(i,k)) + clwt = max(0.0,(clwf(i,k)+cnvw(i,k))) * gfac * delp(i,k) + cip(i,k) = clwt * tem2d(i,k) + cwp(i,k) = clwt - cip(i,k) enddo enddo @@ -2528,7 +1704,7 @@ subroutine progcld4o & endif !> - Compute effective ice cloud droplet radius in Heymsfield and McFarquhar (1996) -!!\cite heymsfield_and_mcfarquhar_1996. +!! \cite heymsfield_and_mcfarquhar_1996 . do k = 1, NLAY do i = 1, IX @@ -2554,24 +1730,30 @@ subroutine progcld4o & enddo enddo + do k = 1, NLAY + do i = 1, IX + cldtot1(i,k) = cldtot(i,k) + enddo + enddo + ! do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) - clouds(i,k,9) = rei(i,k) + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) +! cld_rwp(i,k) = 0.0 + cld_rerain(i,k) = rer(i,k) +! cld_swp(i,k) = 0.0 + cld_resnow(i,k) = res(i,k) enddo enddo ! return !................................... - end subroutine progcld4o + end subroutine progcld_gfdl_lin !! @} !----------------------------------- @@ -2587,7 +1769,8 @@ subroutine progcld_fer_hires & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & & dzlay, cldtot, cldcnv, & - & clouds & ! --- outputs: + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! @@ -2638,16 +1821,16 @@ subroutine progcld_fer_hires & ! dzlay(ix,nlay) : thickness between model layer centers (km) ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -2683,8 +1866,11 @@ subroutine progcld_fer_hires & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds +! --- inputs/outputs + + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & @@ -2767,54 +1953,14 @@ subroutine progcld_fer_hires & !> - Calculate layer cloud fraction. - clwmin = 0.0 if (.not. lmfshal) then - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 - -! tem1 = 1000.0 / tem1 - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo + call cloud_fraction_XuRandall & + & ( IX, NLAY, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs else - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) -! - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - if (lmfdeep2) then - tem1 = xrc3 / tem1 - else - tem1 = 100.0 / tem1 - endif -! - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo + call cloud_fraction_mass_flx_1 & + & ( IX, NLAY, lmfdeep2, xrc3, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) endif endif ! if (uni_cld) then @@ -2844,23 +1990,21 @@ subroutine progcld_fer_hires & enddo enddo endif +! do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) - clouds(i,k,7) = rer(i,k) - !mz inflg .ne.5 - clouds(i,k,8) = 0. - clouds(i,k,9) = 10. -!mz for diagnostics? + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) + cld_rwp(i,k) = crp(i,k) + cld_rerain(i,k) = rer(i,k) + cld_swp(i,k) = 0.0 + cld_resnow(i,k) = 10.0 re_cloud(i,k) = rew(i,k) re_ice(i,k) = rei(i,k) re_snow(i,k) = 10. - enddo enddo ! @@ -2870,8 +2014,7 @@ end subroutine progcld_fer_hires !................................... -!mz: this is the original progcld_fer_hires for Thompson MP (and WSM6), -! to be replaced by the GSL version of progcld_thompson_wsm6 for Thompson MP +! This subroutine is used by Thompson/wsm6 cloud microphysics (EMC) subroutine progcld_thompson_wsm6 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & @@ -2881,7 +2024,8 @@ subroutine progcld_thompson_wsm6 & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, cldtot, cldcnv, & - & clouds & ! --- outputs: + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! @@ -2931,16 +2075,16 @@ subroutine progcld_thompson_wsm6 & ! cldcov : layer cloud fraction (used when uni_cld=.true. ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! ! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! @@ -2981,8 +2125,11 @@ subroutine progcld_thompson_wsm6 & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds +! --- inputs/outputs + + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & @@ -3079,57 +2226,16 @@ subroutine progcld_thompson_wsm6 & !> - Calculate layer cloud fraction. - clwmin = 0.0 if (.not. lmfshal) then - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo + call cloud_fraction_XuRandall & + & ( IX, NLAY, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs else - do k = 1, NLAY-1 - do i = 1, IX - clwt = 1.0e-10 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - if(rhly(i,k) > 0.99) then - cldtot(i,k) = 1. - else - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - if (lmfdeep2) then - tem1 = xrc3 / tem1 - else - tem1 = 100.0 / tem1 - endif - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - else - cldtot(i,k) = 0.0 - endif - enddo - enddo - endif + call cloud_fraction_mass_flx_2 & + & ( IX, NLAY, lmfdeep2, xrc3, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) + endif + endif ! if (uni_cld) then do k = 1, NLAY @@ -3173,15 +2279,15 @@ subroutine progcld_thompson_wsm6 & do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) ! added for Thompson - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) ! added for Thompson - clouds(i,k,9) = res(i,k) + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) + cld_rwp(i,k) = crp(i,k) ! added for Thompson + cld_rerain(i,k) = rer(i,k) + cld_swp(i,k) = csp(i,k) ! added for Thompson + cld_resnow(i,k) = res(i,k) enddo enddo @@ -3212,7 +2318,8 @@ subroutine progcld_thompson & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, gridkm, cldtot, cldcnv, & - & clouds & ! --- outputs: + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! @@ -3263,16 +2370,16 @@ subroutine progcld_thompson & ! cldcov : layer cloud fraction (used when uni_cld=.true. ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -3309,8 +2416,11 @@ subroutine progcld_thompson & & slmsk real(kind=kind_phys), dimension(:), intent(in) :: gridkm -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds +! --- inputs/outputs + + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & @@ -3331,14 +2441,6 @@ subroutine progcld_thompson & clwmin = 1.0E-9 - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo - do k = 1, NLAY do i = 1, IX cldtot(i,k) = 0.0 @@ -3454,15 +2556,15 @@ subroutine progcld_thompson & do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) - clouds(i,k,9) = res(i,k) + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) + cld_rwp(i,k) = crp(i,k) ! added for Thompson + cld_rerain(i,k) = rer(i,k) + cld_swp(i,k) = csp(i,k) ! added for Thompson + cld_resnow(i,k) = res(i,k) enddo enddo @@ -3494,50 +2596,20 @@ end subroutine progcld_thompson !> \ingroup module_radiation_clouds !> This subroutine computes cloud related quantities using !! for unified cloud microphysics scheme. -!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) -!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) -!!\param tlyr (IX,NLAY), model layer mean temperature in K -!!\param tvly (IX,NLAY), model layer virtual temperature in K -!!\param ccnd (IX,NLAY), layer cloud condensate amount -!!\param ncnd number of layer cloud condensate types -!!\param xlat (IX), grid latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment -!!\param xlon (IX), grid longitude in radians (not used) -!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) -!!\param dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\param IX horizontal dimention -!!\param NLAY,NLP1 vertical layer/level dimensions -!!\param cldtot unified cloud fraction from moist physics -!!\param effrl (IX,NLAY), effective radius for liquid water -!!\param effri (IX,NLAY), effective radius for ice water -!!\param effrr (IX,NLAY), effective radius for rain water -!!\param effrs (IX,NLAY), effective radius for snow water -!!\param effr_in logical - if .true. use input effective radii -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles -!!\n (:,:,1) - layer total cloud fraction -!!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ -!!\n (:,:,3) - mean eff radius for liq cloud (micron) -!!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ -!!\n (:,:,5) - mean eff radius for ice cloud (micron) -!!\n (:,:,6) - layer rain drop water path -!!\n (:,:,7) - mean eff radius for rain drop (micron) -!!\n (:,:,8) - layer snow flake water path -!!\n (:,:,9) - mean eff radius for snow flake (micron) -!>\section gen_progclduni progclduni General Algorithm +!>\section progclduni General Algorithm !> @{ subroutine progclduni & & ( plyr,plvl,tlyr,tvly,ccnd,ncnd, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, & & effrl,effri,effrr,effrs,effr_in, & & dzlay, cldtot1, cldcnv, & - & clouds & ! --- outputs: + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progclduni computes cloud related quantities using ! +! subprogram: progclduni computes cloud related quantities using ! ! for unified cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! @@ -3546,8 +2618,11 @@ subroutine progclduni & ! fractions and the vertical indices of low, mid, and high cloud ! ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! +! This program is written by Moorthi ! +! to represent unified cloud across all physics while ! +! using SHOC+MG2/3+convection (RAS or SAS or CSAW) ! ! ! -! usage: call progclduni ! +! usage: call progclduni ! ! ! ! subprograms called: gethml ! ! ! @@ -3583,16 +2658,16 @@ subroutine progclduni & ! dzlay(ix,nlay) : thickness between model layer centers (km) ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! ! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! @@ -3630,8 +2705,12 @@ subroutine progclduni & & slmsk real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot1 -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + +! --- inputs/outputs + + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, cwp, cip, & @@ -3789,15 +2868,15 @@ subroutine progclduni & ! do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) - clouds(i,k,9) = res(i,k) + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) + cld_rwp(i,k) = crp(i,k) ! added for Thompson + cld_rerain(i,k) = rer(i,k) + cld_swp(i,k) = csp(i,k) ! added for Thompson + cld_resnow(i,k) = res(i,k) enddo enddo ! @@ -4688,6 +3767,154 @@ SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte) END SUBROUTINE adjust_cloudFinal + subroutine cloud_fraction_XuRandall & + & ( IX, NLAY, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs + +! --- inputs: + integer, intent(in) :: IX, NLAY + real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, clwf, & + & rhly, qstl + +! --- outputs + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot + +! --- local variables: + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2 + integer :: i, k + +!> - Compute layer cloud fraction. + + clwmin = 0.0 + do k = 1, NLAY + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + + tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) + tem1 = 2000.0 / tem1 + +! tem1 = 1000.0 / tem1 + + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + + end subroutine cloud_fraction_XuRandall + + subroutine cloud_fraction_mass_flx_1 & + & ( IX, NLAY, lmfdeep2, xrc3, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs + +! --- inputs: + integer, intent(in) :: IX, NLAY + real (kind=kind_phys), intent(in) :: xrc3 + real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, clwf, & + & rhly, qstl + logical, intent(in) :: lmfdeep2 + +! --- outputs + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot + +! --- local variables: + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2 + integer :: i, k + +!> - Compute layer cloud fraction. + + clwmin = 0.0 + do k = 1, NLAY + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) +! + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 + else + tem1 = 100.0 / tem1 + endif +! + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + + end subroutine cloud_fraction_mass_flx_1 + + subroutine cloud_fraction_mass_flx_2 & + & ( IX, NLAY, lmfdeep2, xrc3, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs + +! --- inputs: + integer, intent(in) :: IX, NLAY + real (kind=kind_phys), intent(in) :: xrc3 + real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, clwf, & + & rhly, qstl + logical, intent(in) :: lmfdeep2 + +! --- outputs + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot + +! --- local variables: + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2 + integer :: i, k + +!> - Compute layer cloud fraction. + + clwmin = 0.0 + do k = 1, NLAY-1 + do i = 1, IX + clwt = 1.0e-10 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + if(rhly(i,k) > 0.99) then + cldtot(i,k) = 1. + else + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 + else + tem1 = 100.0 / tem1 + endif + + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + else + cldtot(i,k) = 0.0 + endif + enddo + enddo + + end subroutine cloud_fraction_mass_flx_2 !........................................! end module module_radiation_clouds !! @} diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 95bc0b059..6d4f5750d 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -2082,7 +2082,7 @@ subroutine mcica_subcol & ! ! NOTE: The code below is identical for case (4) and (5) because the ! distinction in the vertical correlation between EXP and ER is already -! built into the specification of alpha (in subroutine get_alpha_exp). +! built into the specification of alpha (in subroutine get_alpha_exper). ! --- setup 2 sets of random numbers diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index d09f586a3..4067dd0ec 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -2197,7 +2197,7 @@ subroutine mcica_subcol & ! ! NOTE: The code below is identical for case (4) and (5) because the ! distinction in the vertical correlation between EXP and ER is already -! built into the specification of alpha (in subroutine get_alpha_exp). +! built into the specification of alpha (in subroutine get_alpha_exper). ! --- setup 2 sets of random numbers From c6faeb16c223d0646dace6463f48d63bd0c4040e Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Tue, 22 Feb 2022 21:21:54 +0000 Subject: [PATCH 072/217] updated radiation_cloud_overlap.F90 based on Mike's comment --- physics/radiation_cloud_overlap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/radiation_cloud_overlap.F90 b/physics/radiation_cloud_overlap.F90 index 87f2ebbf0..30c7804b1 100644 --- a/physics/radiation_cloud_overlap.F90 +++ b/physics/radiation_cloud_overlap.F90 @@ -98,7 +98,7 @@ subroutine get_alpha_exper(nCol, nLay, iovr, iovr_exprand, dzlay, & dcorr_lgth ! Decorrelation length (km) real(kind_phys), dimension(nCol,nLay), intent(in) :: & dzlay ! - real(kind_phys), dimension(:,:), intent(in) :: & + real(kind_phys), dimension(nCol,nLay), intent(in) :: & cld_frac ! Outputs From a9349ed2da6a5f6bfc4a55b4fde3ca74410ac02e Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 24 Feb 2022 14:36:20 -0600 Subject: [PATCH 073/217] Added internal documentation (for doxygen). Minor update in microphysics to lower the supersat. threshold at which it allows droplet nucleation at low temperature (T < -36C). This alleviates rare high supersaturation in very deep strong (supercell) updrafts. --- physics/docs/library.bib | 38 ++++++ physics/docs/pdftxt/NSSLMICRO.txt | 35 ++++++ physics/module_mp_nssl_2mom.F90 | 203 +++++++++++++++++++----------- physics/mp_nssl.F90 | 14 ++- 4 files changed, 215 insertions(+), 75 deletions(-) create mode 100644 physics/docs/pdftxt/NSSLMICRO.txt diff --git a/physics/docs/library.bib b/physics/docs/library.bib index 48ef43910..2ee46aac9 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -3310,6 +3310,44 @@ @inproceedings{yudin_et_al_2019 Title = {Longitudinal Variability of Wave Dynamics in Weather Models Extended into the Mesosphere and Thermosphere}, Year = {2019}} +@article{mansell_2013, + Author = {Edward R. Mansell and Conrad L. Ziegler}, + Date-Added = {2015-02-26 22:32:59 +0000}, + Date-Modified = {2020-02-10 23:06:41 +0000}, + Doi = {10.1175/JAS-D-12-0264.1}, + Journal = {Journal of the Atmospheric Sciences}, + Keywords = {storm electrification, microphysics 2-moment}, + Number = {7}, + Pages = {2032-2050}, + Title = {Aerosol Effects on Simulated Storm Electrification and Precipitation in a Two-moment Bulk Microphysics Model}, + Volume = {70}, + Year = {2013}} + +@article{mansell_2010, + Author = {Edward R. Mansell}, + Date-Added = {2011-02-22 10:34:11 -0600}, + Date-Modified = {2011-02-22 10:35:34 -0600}, + Doi = {10.1175/2010JAS3341.1}, + Journal = {Journal of the Atmospheric Sciences}, + Keywords = {advection, microphysics 2-moment}, + Pages = {3084-3094}, + Title = {On Sedimentation and Advection in Multimoment Bulk Microphysics}, + Volume = {67}, + Year = {2010}} + +@article{mansell_etal_2010, + Author = {E. R. Mansell and C. L. Ziegler and E. C. Bruning}, + Date-Added = {2007-08-20 15:44:13 -0500}, + Date-Modified = {2010-04-13 16:55:16 -0500}, + Doi = {10.1175/2009JAS2965.1}, + Journal = {Journal of the Atmospheric Sciences}, + Keywords = {storm electrification, microphysics 2-moment}, + Pages = {171-194}, + Title = {Simulated Electrification of a Small Thunderstorm with Two-Moment Bulk Microphysics}, + Volume = {67}, + Year = {2010}} + + @comment{BibDesk Static Groups{ diff --git a/physics/docs/pdftxt/NSSLMICRO.txt b/physics/docs/pdftxt/NSSLMICRO.txt new file mode 100644 index 000000000..5d94f6600 --- /dev/null +++ b/physics/docs/pdftxt/NSSLMICRO.txt @@ -0,0 +1,35 @@ +/** +\page NSSLMICRO NSSL 2-moment Microphysics Scheme +\section nssl2m_descrp Description + +The NSSL two-moment bulk microphysical parameterization scheme that describes form and phase changes among a range of liquid and ice hydrometeors, as described in Mansell et al. (2010) \cite Mansell_etal_2010 and Mansell and Ziegler (2013) \cite Mansell_2013. The microphysical parameterization predicts the mass mixing ratio and number concentration of cloud droplets, raindrops, cloud ice crystals (columns), snow particles (including large crystals and aggregates), graupel, and (optionally) hail. + +The graupel and hail particle densities are also calculated by predicting the total particle volume. The graupel category therefore emulates a range of characteristics from high-density frozen drops (includes small hail) to low-density graupel (from rimed ice crystals/snow) in its size and density spectrum. The hail category is designed to simulate larger hail sizes. Hail is only produced from higher-density large graupel. + +Hydrometeor size distributions are assumed to follow a gamma functional form. Microphysical processes include cloud droplet and cloud ice nucleation, condensation, deposition, evaporation, sublimation, collection–coalescence, variable-density riming, shedding, ice multiplication, cloud ice aggregation, freezing and melting, and conversions between hydrometeor categories. + +CCN concentration is predicted as in Mansell et al. (2010) with a bulk activation spectrum approximating small aerosols. The model tracks the number of unactivated CCN, and the local CCN concentration is depleted as droplets are activated, either at cloud base or in cloud. The CCN are subjected to advection and subgrid turbulent mixing but have no other interactions with hydrometeors; for example, scavenging by raindrops is omitted. CCN are restored by droplet evaporation and by a gradual regeneration when no hydrometeors are present. Aerosol sensitivity is enhanced by explicitly treating droplet condensation instead of using a saturation adjustment. Supersaturation (within reason) is allowed to persist in updraft with low droplet concentration. + +Excessive size sorting (common in 2-moment schemes) is effectively controlled by an adaptive breakup method that prevents reflectivity growth by sedimentation (Mansell 2010 \cite Mansell_2010). + +The NSSL scheme is designed with deep (severe) convection in mind at grid spacings of 4km or smaller, but can also be run at larger grid spacing as needed for nesting etc. It is also able to capture non-severe and winter weather. + +Namelist parameters: +- \b nssl_hail_on: (logical: .true./.false.) Turns the hail category (3 variables: mass, number, and volume) Default value is .false. Field table variables: hailwat, hail_nc, hail_vol + +- \b nssl_ccn_on: (logical: .true./.false.) Turns prediction on/off for simple CCN number concentration. Default value is .true. Field table variable: ccn_nc + +- \b nssl_cccn: (real) Background CCN concentration at STP. CCN are initialized as a constant number mixing ratio (nssl_cccn/1.225). The default value is 0.6e9 m-3 + +- \b nssl_alphah, nssl_alphahl: (real) Shape parameters for graupel (h) and hail (hl). Default values are 0.0 and 1.0. + + + +\section intra_nssl2m Intraphysics Communication +\ref arg_table_mp_nssl_run + +\section gen_nssl2m General Algorithm +- \ref gen_nssl2m_init +- \ref gen_nssl2m_driver + +*/ diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index fde15fac5..e6f2ae162 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -8,7 +8,7 @@ !--------------------------------------------------------------------- -! code snapshot: "Oct 29 2021" at "19:44:39" +! code snapshot: "Feb 24 2022" at "14:27:57" !--------------------------------------------------------------------- !--------------------------------------------------------------------- ! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: @@ -25,35 +25,39 @@ ! ! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; ! -! This module provides a 2-moment bulk microphysics scheme originally -! developed by Conrad Ziegler (Zeigler, 1985, JAS) and modified/upgraded in -! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation -! follows Mansell (2010, JAS), using parameter infall = 4. -! -! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) -! -! Average graupel particle density is predicted, which affects fall speed as well. -! Hail density prediction is by default disabled in this version, but may be enabled -! at some point if there is interest. -! -! Maintainer: Ted Mansell, National Severe Storms Laboratory -! -! Microphysics References: -! -! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small -! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. -! -! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and -! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, -! doi:10.1175/JAS-D-12-0264.1. -! -! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. -! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. -! -! Sedimentation reference: -! -! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. -! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. +!>\ingroup mod_mp_nssl2m +!! This module provides a 2-moment bulk microphysics scheme described by +!! Mansell, Zeigler, and Bruning (2010, JAS) +!! +!! This module provides a 2-moment bulk microphysics scheme based on a combination of +!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in +!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation +!! follows Mansell (2010, JAS), using parameter infall = 4. +!! +!! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) +!! +!! Average graupel particle density is predicted, which affects fall speed as well. +!! Hail density prediction is by default disabled in this version, but may be enabled +!! at some point if there is interest. +!! +!! Maintainer: Ted Mansell, National Severe Storms Laboratory +!! +!! Microphysics References: +!! +!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small +!! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. +!! +!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and +!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, +!! doi:10.1175/JAS-D-12-0264.1. +!! +!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. +!! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. +!! +!! Sedimentation reference: +!! +!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. +!! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. ! ! Possible parameters to adjust: ! @@ -77,7 +81,8 @@ !--------------------------------------------------------------------- ! Sept. 2021: ! Fixes: -! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed density independent of size. Generally low reflectivity values as a result (no effect on microphysics) +! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed +! density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics) ! Other: ! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect) ! Reordered collection coefficients (dab1lh) to be consistent (no effect) @@ -168,6 +173,9 @@ +!>\defgroup mod_nsslmp NSSL 2-moment microphysics modules +!!\ingroup nsslmp testphrase one +!! Module for NSSL cloud physics MODULE module_mp_nssl_2mom IMPLICIT NONE @@ -561,6 +569,7 @@ MODULE module_mp_nssl_2mom integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting ! when liquid fraction is not predicted + logical :: iwetsoak = .true. ! soak and freeze during wet growth or not integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters ! 1 = original Zrnic et al. (Mansell et al. 2010) @@ -606,6 +615,7 @@ MODULE module_mp_nssl_2mom ! 3 = only add 1.5*cxmin to number concentration (allow max size to apply) ! 4 = add droplets with minimum radius of 20 microns real :: maxsupersat = 1.9 ! maximum supersaturation ratio, above which a saturation adustment is done + real :: maxlowtempss = 1.08 ! Sat. ratio threshold for allowing droplet nucleation at T < tfrh real :: ssmxuf = 4.0 ! supersaturation at which to start using "ultrafine" CCN (if ccnuf > 0.) @@ -1088,7 +1098,6 @@ MODULE module_mp_nssl_2mom delta_alphamlr, & iqvsopt, & maxsupersat, & - charging_border, & do_accurate_sedimentation, interval_sedi_vt ! ##################################################################### ! ##################################################################### @@ -1099,12 +1108,16 @@ MODULE module_mp_nssl_2mom ! ##################################################################### +!>\ingroup mod_nsslmp +!! This function is for saturation vapor pressure with respect to liquid water REAL FUNCTION fqvs(t) implicit none real :: t fqvs = exp(caw*(t-273.15)/(t-cbw)) END FUNCTION fqvs +!>\ingroup mod_nsslmp +!! This function is for saturation vapor pressure with respect to ice REAL FUNCTION fqis(t) implicit none real :: t @@ -1118,6 +1131,8 @@ END FUNCTION fqis ! ##################################################################### +!>\ingroup mod_nsslmp +!! NSSL MP subroutine to initialize physical constants provided by host model SUBROUTINE nssl_2mom_init_const( & con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) @@ -1145,8 +1160,8 @@ SUBROUTINE nssl_2mom_init_const( & END SUBROUTINE nssl_2mom_init_const ! ##################################################################### ! ##################################################################### - - +!>\ingroup mod_nsslmp +!! NSSL MP setup routine (sets local options and array indices) SUBROUTINE nssl_2mom_init( & & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & & nssl_graupelfallfac, & @@ -1243,6 +1258,7 @@ SUBROUTINE nssl_2mom_init( & + IF ( .false. ) THEN ! set to true to enable internal namelist read open(15,file='input.nml',status='old',form='formatted',action='read') rewind(15) @@ -2016,6 +2032,8 @@ END SUBROUTINE nssl_2mom_init ! ##################################################################### ! ##################################################################### +!>\ingroup mod_nsslmp +!! Driver subroutine that copies state data to local 2D arrays for microphysics calls SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & zrw, zhw, zhl, & @@ -2034,7 +2052,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw rscghis_2d,rscghis_2dp,rscghis_2dn, & scr,scw,sci,scs,sch,schl,sctot, & elec_physics, & - induc,elec,scion,sciona, & + induc,elecz,scion,sciona, & noninduc,noninducp,noninducn, & pcc2, pre2, depsubr, & mnucf2, melr2, ctr2, & @@ -2090,7 +2108,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elec ! elecsave = Ez + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn @@ -2194,7 +2212,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw double precision :: grmass1,grmass2 double precision :: hlmass1,hlmass2 double precision :: wvol5,wvol10 - real :: tmp,dv,dv1 + real :: tmp,dv,dv1,tmpchg real :: rdt double precision :: dt1,dt2 @@ -2209,6 +2227,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot real :: fach(kts:kte) + + logical, parameter :: debugdriver = .false. #ifdef MPI @@ -2227,7 +2247,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw rdt = 1.0/dtp -! write(0,*) 'N2M: entering routine' + IF ( debugdriver ) write(0,*) 'N2M: entering routine' flag_qndrop = .false. flag_qnifa = .false. @@ -2283,7 +2303,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw makediag = diagflag .or. itimestep == 1 ENDIF -! write(0,*) 'N2M: makediag = ',makediag + IF ( debugdriver ) write(0,*) 'N2M: makediag = ',makediag nx = ite-its+1 @@ -2346,7 +2366,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw -! write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) + IF ( debugdriver ) write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) ancuten(its:ite,1,kts:kte,:) = 0.0 thproclocal(:,:) = 0.0 @@ -2626,7 +2646,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! copy xfall to appropriate places... -! write(0,*) 'N2M: end sediment, jy = ',jy + IF ( debugdriver ) write(0,*) 'N2M: end sediment, jy = ',jy DO ix = its,ite IF ( lhl > 1 ) THEN @@ -2686,7 +2706,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( isedonly /= 1 ) THEN ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics -! write(0,*) 'N2M: gs, jy = ',jy + IF ( debugdriver ) write(0,*) 'N2M: gs, jy = ',jy ! IF ( isedonly /= 2 ) THEN @@ -2922,6 +2942,8 @@ END SUBROUTINE nssl_2mom_driver ! ##################################################################### ! ##################################################################### +!>\ingroup mod_nsslmp +!! Single-precision complete gamma function REAL FUNCTION GAMMA_SP(xx) implicit none @@ -2960,6 +2982,8 @@ END FUNCTION GAMMA_SP ! ##################################################################### +!>\ingroup mod_nsslmp +!! Douple-precision complete gamma function (single precision input) DOUBLE PRECISION FUNCTION GAMMA_DPR(x) ! dp gamma with real input implicit none @@ -2978,6 +3002,8 @@ end FUNCTION GAMMA_DPR ! ##################################################################### +!>\ingroup mod_nsslmp +!! single-precision incomplete gamma function (single precision args) real function GAMXINF(A1,X1) ! =================================================== @@ -3036,6 +3062,8 @@ END function GAMXINF ! ##################################################################### +!>\ingroup mod_nsslmp +!! Double-precision incomplete gamma function (single precision args) double precision function GAMXINFDP(A1,X1) ! =================================================== @@ -3097,7 +3125,8 @@ END function GAMXINFDP ! ##################################################################### -! #ifdef Z3MOM +!>\ingroup mod_nsslmp +!! Function to interpolate from a table of incomplete gamma function values real function gaminterp(ratio, alp, luindex, ilh) implicit none @@ -3141,7 +3170,6 @@ real function gaminterp(ratio, alp, luindex, ilh) ! ENDIF END FUNCTION gaminterp -! #endif /* Z3MOM */ ! ##################################################################### !**************************** GAML02 *********************** @@ -3149,6 +3177,8 @@ END FUNCTION gaminterp ! It is used for qiacr with the gamma of volume to calculate what ! fraction of drops exceed a certain size (this version is for 40 micron drops) ! ********************************************************** +!>\ingroup mod_nsslmp +!! Function calculates Gamma(0.2,x)/Gamma[0.2] for 40 micro drops ( imurain == 3 ) real FUNCTION GAML02(x) implicit none integer ig, i, ii, n, np @@ -3191,7 +3221,9 @@ END FUNCTION GAML02 ! It is used for qiacr with the gamma of volume to calculate what ! fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb) ! ********************************************************** - real FUNCTION GAML02d300(x) +!>\ingroup mod_nsslmp +!! Function calculates fraction of drops larger than 300 microns ( imurain == 3 ) + real FUNCTION GAML02d300(x) implicit none integer ig, i, ii, n, np real x @@ -3237,6 +3269,8 @@ END FUNCTION GAML02d300 ! It is used for qiacr with the gamma of volume to calculate what ! fraction of drops exceed a certain size (this version is for 500 micron drops) (see zieglerstuff.nb) ! ********************************************************** +!>\ingroup mod_nsslmp +!! Function calculates Gamma(0.2,x)/Gamma[0.2] for 500 micro drops ( imurain == 3 ) real FUNCTION GAML02d500(x) implicit none integer ig, i, ii, n, np @@ -3307,6 +3341,8 @@ END function BETA ! ##################################################################### ! ##################################################################### +!>\ingroup mod_nsslmp +!! Douple-precision complete gamma function (double precision argument) DOUBLE PRECISION FUNCTION GAMMA_DP(xx) implicit none @@ -3340,6 +3376,8 @@ DOUBLE PRECISION FUNCTION GAMMA_DP(xx) END function gamma_dp ! ##################################################################### +!>\ingroup mod_nsslmp +!! Double-precision complete gamma function subroutine (used by beta function routine) SUBROUTINE GAMMADP(X,GA) ! ! ================================================== @@ -3411,6 +3449,8 @@ END SUBROUTINE GAMMADP ! ! ! ##################################################################### +!>\ingroup mod_nsslmp +!! Function calculates collection coefficients following Siefert (2006) Function delbk(bb,nu,mu,k) ! ! Purpose: Caluculates collection coefficients following Siefert (2006) @@ -3466,6 +3506,8 @@ END Function delbk ! ! ##################################################################### ! Equation (91) in Seifert and Beheng (2006) ("a" collecting "b") +!>\ingroup mod_nsslmp +!! Function calculates collection coefficients following Siefert (2006) Function delabk(ba,bb,nua,nub,mua,mub,k) implicit none @@ -3524,25 +3566,9 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) END Function delabk -! ##################################################################### -! -! ##################################################################### -!-------------------------------------------------------------------------- - subroutine cld_cpu(string) - - implicit none - character( LEN = * ) string - - return - - end subroutine cld_cpu - -! -!-------------------------------------------------------------------------- -! -!-------------------------------------------------------------------------- -! - subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & +!>\ingroup mod_nsslmp +!! Sedimentation driver subroutine. Calls fallout column by column + subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & t0,t7,infdo,jslab,its,jts, & & timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing ! @@ -3958,6 +3984,8 @@ END SUBROUTINE SEDIMENT1D ! !-------------------------------------------------------------------------- ! +!>\ingroup mod_nsslmp +!! Column sedimentation fallout subroutine subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & & a,db1,ia,id,xfall,dtz1,ixcol) ! @@ -4070,6 +4098,8 @@ END SUBROUTINE FALLOUT1D ! ############################################################################## ! ############################################################################## +!>\ingroup mod_nsslmp +!! Calculates temporary reflectivity moment for adaptive size-sorting limiter subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol) @@ -4188,6 +4218,8 @@ END subroutine calczgr1d ! Calculation is in a slab (constant jgs) ! +!>\ingroup mod_nsslmp +!! Subroutine to correct number concentration to prevent reflectivity growth subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & & z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, & & lvol, rho_qx, infall, ixcol) @@ -4381,6 +4413,8 @@ END subroutine calcnfromz1d ! ! 10.27.2015: Added hail calculation ! +!>\ingroup mod_nsslmp +!! Subroutine to calculate number concentrations from initial state that has only mixing ratio. subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & & qcw,qci,qsw,qrw,qhw,qhl, & & ccw,cci,csw,crw,chw,chl, & @@ -4726,6 +4760,8 @@ END subroutine calcnfromq ! ! 10.27.2015: Added hail calculation ! +!>\ingroup mod_nsslmp +!! Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio. subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) @@ -4915,6 +4951,8 @@ END subroutine calcnfromcuten ! ##################################################################### ! ##################################################################### +!>\ingroup mod_nsslmp +!! Subroutine to calculate effective radii for use by radiation routines SUBROUTINE calc_eff_radius & & (nx,ny,nz,na,jyslab & & ,nor,norz & @@ -5096,6 +5134,8 @@ END SUBROUTINE calc_eff_radius ! ##################################################################### ! ##################################################################### +!>\ingroup mod_nsslmp +!! Subroutine that returns the maximum possible condensation SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt) @@ -5255,6 +5295,8 @@ END SUBROUTINE QVEXCESS ! ! ############################################################################## ! +!>\ingroup mod_nsslmp +!! Mean hydrometeor size and fall speed calculations SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, & @@ -6497,7 +6539,6 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & aax = ax(il) vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y ENDIF - ! vtxbar(mgs,il,2) = & ! & rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* & ! & x)/y @@ -6519,7 +6560,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,il,3) = rhovt(mgs)* & & (aax*(xdia(mgs,il,1) )**bbx * & & x)/y -! & Gamma(7.0 + alpha(mgs,il) + bbx))/Gamma(7. + alpha(mgs,il)) +! & Gamma(7.0 + alpha(mgs,il) + bbx)/Gamma(7. + alpha(mgs,il)) IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y @@ -6637,6 +6678,8 @@ END SUBROUTINE setvtz ! subroutine to calculate fall speeds of hydrometeors ! +!>\ingroup mod_nsslmp +!! Column-wise front end to setvtz for sedimentation subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & & xvt, rhovtzx, & & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, & @@ -7145,6 +7188,8 @@ END subroutine ziegfall1d ! ##################################################################### ! ############################################################################## +!>\ingroup mod_nsslmp +!! Radar reflectivity calculation. Assumes ideal Rayleigh scattering. subroutine radardd02(nx,ny,nz,nor,na,an,temk, & & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit) ! @@ -7775,7 +7820,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN ! IF ( .true. ) THEN - IF ( qxw > qsmin .or. iusewetsnow >= 2) THEN ! old version + IF ( qxw > qsmin .or. iusewetsnow >= 2 ) THEN ! old version ! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & ! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & @@ -8144,6 +8189,8 @@ END subroutine radardd02 ! ############################################################################## +!>\ingroup mod_nsslmp +!! Droplet nucleation routine. Explicit condensation/evaporation. Tiny mixing ratio cleanup. ! ##################################################################### ! ##################################################################### ! @@ -8474,7 +8521,7 @@ SUBROUTINE NUCOND & if ( temg(1) .lt. tfr ) then end if ! - if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxsupersat ) .and. & + if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxlowtempss ) .and. & & ( an(ix,jy,kz,lv) .gt. qss(1) .or. & & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) & @@ -8806,7 +8853,9 @@ SUBROUTINE NUCOND & DO mgs=1,ngscnt dcloud = 0.0 - IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxsupersat ) THEN + ! Skip points at low temperature if SS stays less than 1.08, + ! otherwise allow nucleation at low temp (will freeze at next time step) + IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxlowtempss ) THEN CYCLE ENDIF @@ -10266,6 +10315,8 @@ END SUBROUTINE NUCOND ! ##################################################################### ! ##################################################################### +!>\ingroup mod_nsslmp +!! Main microphysical processes routine @@ -10743,6 +10794,7 @@ subroutine nssl_2mom_gs & real :: vtxbar(ngs,lc:lhab,3) real :: xmas(ngs,lc:lhab) real :: xdn(ngs,lc:lhab) + real :: xdntmp(ngs,lc:lhab) real :: cdxgs(ngs,lc:lhab) real :: xdia(ngs,lc:lhab,3) real :: vtwtdia(ngs,lr:lhab) ! sweep-out volume weighted diameter @@ -12187,6 +12239,7 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 ) THEN xdn(mgs,lhl) = xdn0(lhl) + xdntmp(mgs,lhl) = xdn0(lhl) IF ( lvol(lhl) .gt. 1 ) THEN IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN @@ -12198,6 +12251,7 @@ subroutine nssl_2mom_gs & xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + xdntmp(mgs,lhl) = xdn(mgs,lhl) ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value @@ -14422,7 +14476,7 @@ subroutine nssl_2mom_gs & cautn(mgs) = Min(ccmxd(mgs), & & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) cautn(mgs) = Max( 0.0d0, cautn(mgs) ) - IF ( rb(mgs) .le. 7.51d-6 ) THEN + IF ( rb(mgs) .le. 7.51d-6 .or. dmrauto == -1) THEN t2s = 1.d30 ! cautn(mgs) = 0.0 ELSE @@ -16508,6 +16562,8 @@ subroutine nssl_2mom_gs & IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN ! rescale volumes to maximum density + IF ( iwetsoak ) THEN + rimdn(mgs,lh) = xdnmx(lh) raindn(mgs,lh) = xdnmx(lh) vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh) @@ -16521,7 +16577,10 @@ subroutine nssl_2mom_gs & v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion vhsoak(mgs) = Min(v1,v2) + + ENDIF + ENDIF vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) @@ -16577,6 +16636,8 @@ subroutine nssl_2mom_gs & IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN ! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN + IF ( iwetsoak ) THEN + rimdn(mgs,lhl) = xdnmx(lhl) raindn(mgs,lhl) = xdnmx(lhl) vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) @@ -16600,6 +16661,8 @@ subroutine nssl_2mom_gs & ! vhlacw(mgs) = 0.0 ! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl) + ENDIF + ENDIF vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 8ce37ecaf..7101d50b0 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -2,8 +2,8 @@ !! This file contains NSSL 2-moment MP scheme. -!>\defgroup aanssl NSSL MP Module -!! This module contains the NSSL microphysics scheme. +!>\defgroup nsslmp NSSL MP Module +!! This module contains the front end to NSSL microphysics scheme. module mp_nssl use machine, only : kind_phys, kind_real @@ -19,8 +19,11 @@ module mp_nssl contains +!>\ingroup nsslmp !> This subroutine is a wrapper around the nssl_2mom_init(). !! \section arg_table_mp_nssl_init Argument Table +!>@{ +!> \section arg_table_mp_nssl_init Argument Table !! \htmlinclude mp_nssl_init.html !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & @@ -138,9 +141,10 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & return end subroutine mp_nssl_init +!>@} -!>\ingroup aanssl -!>\section gen_nssl NSSL MP General Algorithm +!>\ingroup nsslmp +!>\section gen_nssl NSSL MP General Algorithm: interface to driver !>@{ !> \section arg_table_mp_nssl_run Argument Table !! \htmlinclude mp_nssl_run.html @@ -390,7 +394,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & !> - Convert omega in Pa s-1 to vertical velocity w in m s-1 w = -omega/(rho*con_g) - !> - Layer width in m from geopotential in m2 s-2 + !> - Layer thickness in m from geopotential in m2 s-2 dz = (phii(:,2:nlev+1) - phii(:,1:nlev)) / con_g ! Accumulated values inside scheme, not used; From 6e6acb941099775a6d78e68dc6f01b8e25818486 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 25 Feb 2022 15:35:28 +0000 Subject: [PATCH 074/217] Initial commit --- physics/GFS_rrtmgp_cloud_mp.F90 | 671 +++++++++++++++++++++++++++++++ physics/GFS_rrtmgp_cloud_mp.meta | 580 ++++++++++++++++++++++++++ 2 files changed, 1251 insertions(+) create mode 100644 physics/GFS_rrtmgp_cloud_mp.F90 create mode 100644 physics/GFS_rrtmgp_cloud_mp.meta diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 new file mode 100644 index 000000000..f3444464a --- /dev/null +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -0,0 +1,671 @@ +! ######################################################################################## +! ######################################################################################## +module GFS_rrtmgp_cloud_mp + use machine, only: kind_phys + use radiation_tools, only: check_error_msg + use rrtmgp_lw_cloud_optics, only: & + radliq_lwr => radliq_lwrLW, radliq_upr => radliq_uprLW,& + radice_lwr => radice_lwrLW, radice_upr => radice_uprLW + use module_mp_thompson, only: calc_effectRad, Nt_c, re_qc_min, re_qc_max, re_qi_min, & + re_qi_max, re_qs_min, re_qs_max + use module_mp_thompson_make_number_concentrations, only: make_IceNumber, & + make_DropletNumber, make_RainNumber + + real (kind_phys), parameter :: & + cld_limit_lower = 0.001, & + cld_limit_ovcst = 1.0 - 1.0e-8, & + reliq_def = 10.0 , & ! Default liq radius to 10 micron (used when effr_in=F) + reice_def = 50.0, & ! Default ice radius to 50 micron (used when effr_in=F) + rerain_def = 1000.0, & ! Default rain radius to 1000 micron (used when effr_in=F) + resnow_def = 250.0, & ! Default snow radius to 250 micron (used when effr_in=F) + reice_min = 10.0, & ! Minimum ice size allowed by GFDL MP scheme + reice_max = 150.0 ! Maximum ice size allowed by GFDL MP scheme + + public GFS_rrtmgp_cloud_mp_init, GFS_rrtmgp_cloud_mp_run, GFS_rrtmgp_cloud_mp_finalize + +contains + ! ###################################################################################### + ! ###################################################################################### + subroutine GFS_rrtmgp_cloud_mp_init() + end subroutine GFS_rrtmgp_cloud_mp_init + +!! \section arg_table_GFS_rrtmgp_cloud_mp_run +!! \htmlinclude GFS_rrtmgp_cloud_mp_run_html +!! + ! ###################################################################################### + ! ###################################################################################### + subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & + i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, kdt, & + imfdeepcnv, imfdeepcnv_gf, doSWrad, doLWrad, effr_in, lmfshal, ltaerosol, icloud, & + imp_physics, imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & + imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, lgfdlmprad, & + imp_physics_fer_hires, do_mynnedmf, uni_cld, lmfdeep2, p_lev, p_lay, t_lay, qs_lay, q_lay, relhum, & + lsmask, tv_lay, effrin_cldliq, effrin_cldice, effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cnv_cldfrac, qci_conv, & + con_g, con_rd, con_eps, con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & + cld_rerain, precip_frac, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice, lwp_ex, iwp_ex, lwp_fc, iwp_fc, errmsg, errflg) + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev, & ! Number of vertical layers + ncnd, & ! Number of cloud condensation types. + nTracers, & ! Number of tracers from model. + i_cldliq, & ! Index into tracer array for cloud liquid. + i_cldice, & ! Index into tracer array for cloud ice. + i_cldrain, & ! Index into tracer array for cloud rain. + i_cldsnow, & ! Index into tracer array for cloud snow. + i_cldgrpl, & ! Index into tracer array for cloud groupel. + i_cldtot, & ! Index into tracer array for cloud total amount. + i_cldliq_nc, & ! cloud liquid number concentration. + i_cldice_nc, & ! cloud ice number concentration. + i_twa, & ! water friendly aerosol. + imfdeepcnv, & ! Choice of mass-flux deep convection scheme + imfdeepcnv_gf, & ! Flag for Grell-Freitas deep convection scheme + kdt, & ! Current forecast iteration + imp_physics, & ! Choice of microphysics scheme + imp_physics_thompson, & ! Choice of Thompson + imp_physics_gfdl, & ! Choice of GFDL + imp_physics_zhao_carr, & ! Choice of Zhao-Carr + imp_physics_zhao_carr_pdf, & ! Choice of Zhao-Carr + PDF clouds + imp_physics_mg, & ! Choice of Morrison-Gettelman + imp_physics_wsm6, & ! Choice of WSM6 + imp_physics_fer_hires, & ! Choice of Ferrier-Aligo + icloud ! Control for cloud are fraction option + logical, intent(in) :: & + doSWrad, & ! Call SW radiation? + doLWrad, & ! Call LW radiation? + effr_in, & ! Provide hydrometeor radii from macrophysics? + lmfshal, & ! Flag for mass-flux shallow convection scheme used by Xu-Randall + ltaerosol, & ! Flag for aerosol option + lgfdlmprad, & ! Flag for GFDLMP radiation interaction + do_mynnedmf, & ! Flag to activate MYNN-EDMF + uni_cld, & ! Flag for unified cloud scheme + lmfdeep2, & ! Flag for mass flux deep convection + doGP_cldoptics_LUT, & ! Flag to do GP cloud-optics (LUTs) + doGP_cldoptics_PADE ! (PADE approximation) + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_rd, & ! Physical constant: gas-constant for dry air + con_ttp, & ! Triple point temperature of water (K) + con_eps ! Physical constant: gas constant air / gas constant H2O + real(kind_phys), dimension(:), intent(in) :: & + lsmask ! Land/Sea mask + real(kind_phys), dimension(:,:), intent(in) :: & + tv_lay, & ! Virtual temperature (K) + t_lay, & ! Temperature (K) + qs_lay, & ! Saturation vapor pressure (Pa) + q_lay, & ! water-vapor mixing ratio (kg/kg) + relhum, & ! Relative humidity + p_lay, & ! Pressure at model-layers (Pa) + cnv_mixratio, & ! Convective cloud mixing-ratio (kg/kg) + cnv_cldfrac, & ! Convective cloud-fraction (1) + qci_conv ! + real(kind_phys), dimension(:,:), intent(inout) :: & + effrin_cldliq, & ! Effective radius for stratiform liquid cloud-particles (microns) + effrin_cldice, & ! Effective radius for stratiform ice cloud-particles (microns) + effrin_cldsnow ! Effective radius for stratiform snow cloud-particles (microns) + real(kind_phys), dimension(:,:), intent(in) :: & + effrin_cldrain ! Effective radius for stratiform rain cloud-particles (microns) + real(kind_phys), dimension(:,:), intent(in) :: & + p_lev ! Pressure at model-level interfaces (Pa) + real(kind_phys), dimension(:,:,:),intent(in) :: & + tracer ! Cloud condensate amount in layer by type () + + ! Outputs + real(kind_phys), dimension(:), intent(inout) :: & + lwp_ex, & ! Total liquid water path from explicit microphysics + iwp_ex, & ! Total ice water path from explicit microphysics + lwp_fc, & ! Total liquid water path from cloud fraction scheme + iwp_fc ! Total ice water path from cloud fraction scheme + real(kind_phys), dimension(:,:),intent(inout) :: & + cld_frac, & ! Total cloud fraction + cld_lwp, & ! Cloud liquid water path + cld_reliq, & ! Cloud liquid effective radius + cld_iwp, & ! Cloud ice water path + cld_reice, & ! Cloud ice effecive radius + cld_swp, & ! Cloud snow water path + cld_resnow, & ! Cloud snow effective radius + cld_rwp, & ! Cloud rain water path + cld_rerain, & ! Cloud rain effective radius + precip_frac, & ! Precipitation fraction + cnv_cld_lwp, & ! Water path for convective liquid cloud-particles (microns) + cnv_cld_reliq, & ! Effective radius for convective liquid cloud-particles (microns) + cnv_cld_iwp, & ! Water path for convective ice cloud-particles (microns) + cnv_cld_reice ! Effective radius for convective ice cloud-particles (microns) + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag + + ! Local + integer :: iCol, iLay + + if (.not. (doSWrad .or. doLWrad)) return + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (imp_physics == imp_physics_gfdl) then + if (.not. lgfdlmprad) then + ! Call progcld_gfdl_lin + else + + ! The cloud-fraction used for the radiation is conditional on other mp choices. + do iLay = 1, nLev + do iCol = 1, nCol + if ((imfdeepcnv==imfdeepcnv_gf .or. do_mynnedmf) .and. kdt>1) then + if (do_mynnedmf) then + if (tracer(iCol,iLay,i_cldrain)>1.0e-7 .OR. tracer(iCol,iLay,i_cldsnow)>1.0e-7) then + cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) + endif + else + if (qci_conv(iCol,iLay) <= 0.) then + cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) + endif + endif + else + cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) + endif + enddo + enddo + + call cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & + i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, p_lev, p_lay, t_lay, & + tv_lay, effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, con_g, con_rd, & + con_ttp, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, & + cld_rwp, cld_rerain, effrin_cldrain=effrin_cldrain) + end if + endif + ! + if (imp_physics == imp_physics_thompson) then + ! Update particle size using modified mixing-ratios. + call update_reff(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, i_cldliq_nc, & + i_twa, q_lay, p_lay, t_lay, tracer, con_eps, con_rd, ltaerosol, effrin_cldliq, & + effrin_cldice, effrin_cldsnow) + cld_reliq = effrin_cldliq + cld_reice = effrin_cldice + cld_resnow = effrin_cldsnow + + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then + if (icloud == 3) then + ! Call progcld_thompson + else + call cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & + i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, p_lev, p_lay, t_lay, & + tv_lay, effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, con_g, con_rd, & + con_ttp, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, & + cld_resnow, cld_rwp, cld_rerain) + endif + else + if (icloud == 3) then + ! Call progcld_thompson + else + ! + call cloud_mp_convective(nCol, nLev, t_lay, p_lev, cnv_mixratio, cnv_cldfrac, & + con_ttp, con_g, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice) + ! + call cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & + i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, p_lev, & + p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, relhum, con_g, con_rd, con_eps, & + lmfshal, ltaerosol, imfdeepcnv, imfdeepcnv_gf, uni_cld, lmfdeep2, & + lwp_ex, iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp, cld_iwp, cld_swp, cld_rwp) + endif + endif + endif + + ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from + ! 2.5 - 21.5 microns for liquid clouds, + ! 10 - 180 microns for ice-clouds + if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then + where(cld_reliq .lt. radliq_lwr) cld_reliq = radliq_lwr + where(cld_reliq .gt. radliq_upr) cld_reliq = radliq_upr + where(cld_reice .lt. radice_lwr) cld_reice = radice_lwr + where(cld_reice .gt. radice_upr) cld_reice = radice_upr + endif + + precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) + + end subroutine GFS_rrtmgp_cloud_mp_run + + ! ###################################################################################### + ! ###################################################################################### + subroutine GFS_rrtmgp_cloud_mp_finalize() + end subroutine GFS_rrtmgp_cloud_mp_finalize + + ! ###################################################################################### + ! ###################################################################################### + subroutine cloud_mp_convective(nCol, nLev, t_lay, p_lev, cnv_mixratio, cnv_cldfrac, & + con_ttp, con_g, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice) + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev ! Number of vertical layers + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_ttp ! Triple point temperature of water (K) + real(kind_phys), dimension(:,:),intent(in) :: & + t_lay, & ! Temperature at layer centers (K) + p_lev, & ! Pressure at layer interfaces (Pa) + cnv_mixratio, & ! Convective cloud mixing-ratio (kg/kg) + cnv_cldfrac ! Convective cloud-fraction (1) + ! Outputs + real(kind_phys), dimension(:,:),intent(inout) :: & + cnv_cld_lwp, & ! Convective cloud liquid water path + cnv_cld_reliq, & ! Convective cloud liquid effective radius + cnv_cld_iwp, & ! Convective cloud ice water path + cnv_cld_reice ! Convective cloud ice effecive radius + ! Local + integer :: iCol, iLay + real(kind_phys) :: tem1, deltaP, clwc + + do iLay = 1, nLev + do iCol = 1, nCol + if (cnv_cldfrac(iCol,iLay) > cld_limit_lower) then + tem1 = min(1.0, max(0.0, (con_ttp-t_lay(iCol,iLay))*0.05)) + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. + clwc = max(0.0, cnv_mixratio(iCol,iLay)) * con_g * deltaP + cnv_cld_iwp(iCol,iLay) = clwc * tem1 + cnv_cld_lwp(iCol,iLay) = clwc - cnv_cld_iwp(iCol,iLay) + cnv_cld_reliq(iCol,iLay) = reliq_def + cnv_cld_reice(iCol,iLay) = reice_def + else + cnv_cld_iwp(iCol,iLay) = 0._kind_phys + cnv_cld_lwp(iCol,iLay) = 0._kind_phys + cnv_cld_reliq(iCol,iLay) = 0._kind_phys + cnv_cld_reice(iCol,iLay) = 0._kind_phys + endif + enddo + enddo + + end subroutine cloud_mp_convective + + ! ###################################################################################### + ! ###################################################################################### + subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & + i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, p_lev, p_lay, t_lay, tv_lay,& + effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, con_g, con_rd, con_ttp, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & + cld_rerain, effrin_cldrain) + implicit none + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev, & ! Number of vertical layers + ncnd, & ! Number of cloud condensation types. + nTracers, & ! Number of tracers from model. + i_cldliq, & ! Index into tracer array for cloud liquid. + i_cldice, & ! Index into tracer array for cloud ice. + i_cldrain, & ! Index into tracer array for cloud rain. + i_cldsnow, & ! Index into tracer array for cloud snow. + i_cldgrpl, & ! Index into tracer array for cloud groupel. + i_cldtot, & ! Index into tracer array for cloud total amount. + kdt + logical, intent(in) :: & + effr_in ! Provide hydrometeor radii from macrophysics? + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_ttp, & ! Triple point temperature of water (K) + con_rd ! Physical constant: gas-constant for dry air + real(kind_phys), dimension(:), intent(in) :: & + lsmask + real(kind_phys), dimension(:,:), intent(in) :: & + t_lay, & ! Temperature at model-layers (K) + tv_lay, & ! Virtual temperature (K) + p_lay, & ! Pressure at model-layers (Pa) + cld_frac, & ! Total cloud fraction + effrin_cldliq, & ! Effective radius for liquid cloud-particles (microns) + effrin_cldice, & ! Effective radius for ice cloud-particles (microns) + effrin_cldsnow ! Effective radius for snow cloud-particles (microns) + real(kind_phys), dimension(:,:), intent(in) ,optional :: & + effrin_cldrain ! Effective radius for rain cloud-particles (microns) + real(kind_phys), dimension(:,:), intent(in) :: & + p_lev ! Pressure at model-level interfaces (Pa) + real(kind_phys), dimension(:,:,:),intent(in) :: & + tracer ! Cloud condensate amount in layer by type () + + ! Outputs + real(kind_phys), dimension(:,:),intent(inout) :: & + cld_lwp, & ! Cloud liquid water path + cld_reliq, & ! Cloud liquid effective radius + cld_iwp, & ! Cloud ice water path + cld_reice, & ! Cloud ice effecive radius + cld_swp, & ! Cloud snow water path + cld_resnow, & ! Cloud snow effective radius + cld_rwp, & ! Cloud rain water path + cld_rerain ! Cloud rain effective radius + + ! Local variables + real(kind_phys) :: tem1,tem2,tem3,pfac + real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate + integer :: iCol,iLay,l,ncndl + real(kind_phys), dimension(nCol,nLev) :: deltaP + + ! Cloud condensate + cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water + cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water + if (ncnd > 2) then + cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain water + cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel + tracer(1:nCol,1:nLev,i_cldgrpl) + endif + + ! Cloud water path (g/m2) + deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. + do iLay = 1, nLev + do iCol = 1, nCol + ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) + if (cld_frac(iCol,iLay) > cld_limit_lower) then + tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) + cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) + cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) + if (ncnd > 2) then + cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) + cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) + endif + endif + enddo + enddo + + ! Particle size + do iLay = 1, nLev + do iCol = 1, nCol + ! Use radii provided from the macrophysics + if (effr_in) then + cld_reliq(iCol,iLay) = effrin_cldliq(iCol,iLay) + cld_reice(iCol,iLay) = max(reice_min, min(reice_max,effrin_cldice(iCol,iLay))) + cld_resnow(iCol,iLay) = effrin_cldsnow(iCol,iLay) + if (present(effrin_cldrain)) then + cld_rerain(iCol,iLay) = effrin_cldrain(iCol,iLay) + else + cld_rerain(iCol,iLay) = rerain_def + endif + else + ! Compute effective liquid cloud droplet radius over land. + if (nint(lsmask(iCol)) == 1) then + cld_reliq(iCol,iLay) = 5.0 + 5.0 * min(1.0, max(0.0, (con_ttp-t_lay(iCol,iLay))*0.05)) + endif + ! Compute effective ice cloud droplet radius following Heymsfield + ! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. + tem2 = t_lay(iCol,iLay) - con_ttp + if (cld_iwp(iCol,iLay) > 0.0) then + tem3 = (con_g/con_rd ) * cld_iwp(iCol,iLay) * (0.01*p_lay(iCol,iLay)) / (deltaP(iCol,iLay)*tv_lay(iCol,iLay)) + if (tem2 < -50.0) then + cld_reice(iCol,iLay) = (1250.0/9.917) * tem3 ** 0.109 + elseif (tem2 < -40.0) then + cld_reice(iCol,iLay) = (1250.0/9.337) * tem3 ** 0.08 + elseif (tem2 < -30.0) then + cld_reice(iCol,iLay) = (1250.0/9.208) * tem3 ** 0.055 + else + cld_reice(iCol,iLay) = (1250.0/9.387) * tem3 ** 0.031 + endif + cld_reice(iCol,iLay) = max(10.0, min(cld_reice(iCol,iLay), 150.0)) + endif + endif ! effr_in + enddo ! nCol + enddo ! nLev + + end subroutine cloud_mp_uni + ! ###################################################################################### + ! ###################################################################################### + subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& + i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, p_lev, & + p_lay, tv_lay, t_lay, tracer, & + qs_lay, q_lay, relhum, con_g, con_rd, con_eps, lmfshal, ltaerosol, imfdeepcnv, & + imfdeepcnv_gf, uni_cld, lmfdeep2, & + lwp_ex, iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp, cld_iwp, cld_swp, cld_rwp) + implicit none + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev, & ! Number of vertical layers + ncnd, & ! Number of cloud condensation types. + nTracers, & ! Number of tracers from model. + i_cldliq, & ! Index into tracer array for cloud liquid amount. + i_cldice, & ! cloud ice amount. + i_cldrain, & ! cloud rain amount. + i_cldsnow, & ! cloud snow amount. + i_cldgrpl, & ! cloud groupel amount. + i_cldtot, & ! cloud total amount. + i_cldliq_nc, & ! cloud liquid number concentration. + i_cldice_nc, & ! cloud ice number concentration. + i_twa, & ! water friendly aerosol. + imfdeepcnv, & ! Choice of mass-flux deep convection scheme + imfdeepcnv_gf ! Flag for Grell-Freitas deep convection scheme + logical, intent(in) :: & + uni_cld, & ! Flag for unified cloud scheme + lmfshal, & ! Flag for mass-flux shallow convection scheme used by Xu-Randall + ltaerosol, & ! Flag for aerosol option + lmfdeep2 ! Flag for mass flux deep convection + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_rd, & ! Physical constant: gas-constant for dry air + con_eps ! Physical constant: gas constant air / gas constant H2O + + real(kind_phys), dimension(:,:), intent(in) :: & + tv_lay, & ! Virtual temperature (K) + t_lay, & ! Temperature (K) + qs_lay, & ! Saturation vapor pressure (Pa) + q_lay, & ! water-vapor mixing ratio (kg/kg) + relhum, & ! Relative humidity + p_lay ! Pressure at model-layers (Pa) + real(kind_phys), dimension(:,:), intent(in) :: & + p_lev ! Pressure at model-level interfaces (Pa) + real(kind_phys), dimension(:,:,:),intent(in) :: & + tracer ! Cloud condensate amount in layer by type () + + ! In/Outs + real(kind_phys), dimension(:), intent(inout) :: & + lwp_ex, & ! total liquid water path from explicit microphysics + iwp_ex, & ! total ice water path from explicit microphysics + lwp_fc, & ! total liquid water path from cloud fraction scheme + iwp_fc ! total ice water path from cloud fraction scheme + real(kind_phys), dimension(:,:), intent(inout) :: & + cld_frac, & ! Total cloud fraction + cld_lwp, & ! Cloud liquid water path + cld_iwp, & ! Cloud ice water path + cld_swp, & ! Cloud snow water path + cld_rwp ! Cloud rain water path + + ! Local variables + real(kind_phys) :: alpha0, pfac, tem1, cld_mr + real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate + integer :: iCol,iLay,l + real(kind_phys), dimension(nCol,nLev) :: deltaP + + ! Cloud condensate + cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water + cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water + cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain water + cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel + tracer(1:nCol,1:nLev,i_cldgrpl) + + ! Cloud water path (g/m2) + deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. + do iLay = 1, nLev + do iCol = 1, nCol + ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) + tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) + cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) + cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) + cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) + cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) + enddo + enddo + + ! Compute cloud-fraction. Only if not pre-computed + if(.not. uni_cld) then + ! Cloud-fraction + if(.not. lmfshal) then + alpha0 = 2000. ! Default (from GATE simulations) + else + if (lmfdeep2) then + alpha0 = 200 + else + alpha0 = 100 + endif + endif + + ! Xu-Randall (1996) cloud-fraction. Conditioned on relative-humidity + do iLay = 1, nLev + do iCol = 1, nCol + if (relhum(iCol,iLay) > 0.99) then + cld_frac(iCol,iLay) = 1._kind_phys + else + cld_mr = cld_condensate(iCol,iLay,1) + cld_condensate(iCol,iLay,2) + & + cld_condensate(iCol,iLay,4) + cld_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & + qs_lay(iCol,iLay), relhum(iCol,iLay), cld_mr, alpha0) + endif + enddo + enddo + else + cld_frac = tracer(:,:,i_cldtot) + endif + + ! Sum the liquid water and ice paths that come from explicit micro + ! What portion of water and ice contents is associated with the partly cloudy boxes? + do iCol = 1, nCol + lwp_ex(iCol) = 0.0 + iwp_ex(iCol) = 0.0 + lwp_fc(iCol) = 0.0 + iwp_fc(iCol) = 0.0 + do iLay = 1, nLev-1 + lwp_ex(iCol) = lwp_ex(iCol) + cld_lwp(iCol,iLay) + iwp_ex(iCol) = iwp_ex(iCol) + cld_iwp(iCol,iLay) + cld_swp(iCol,iLay) + if (cld_frac(iCol,iLay) .ge. cld_limit_lower .and. & + cld_frac(iCol,iLay) .lt. cld_limit_ovcst) then + lwp_fc(iCol) = lwp_fc(iCol) + cld_lwp(iCol,iLay) + iwp_fc(iCol) = iwp_fc(iCol) + cld_iwp(iCol,iLay) + cld_swp(iCol,iLay) + endif + enddo + lwp_fc(iCol) = lwp_fc(iCol)*1.E-3 + iwp_fc(iCol) = iwp_fc(iCol)*1.E-3 + lwp_ex(iCol) = lwp_ex(iCol)*1.E-3 + iwp_ex(iCol) = iwp_ex(iCol)*1.E-3 + enddo + + end subroutine cloud_mp_thompson + + ! ###################################################################################### + ! This function computes the cloud-fraction following. + ! Xu-Randall(1996) A Semiempirical Cloudiness Parameterization for Use in Climate Models + ! https://doi.org/10.1175/1520-0469(1996)053<3084:ASCPFU>2.0.CO;2 + ! + ! cld_frac = {1-exp[-alpha*cld_mr/((1-relhum)*qs_lay)**lambda]}*relhum**P + ! + ! ###################################################################################### + function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) + + ! Inputs + real(kind_phys), intent(in) :: & + p_lay, & ! Pressure (Pa) + qs_lay, & ! Saturation vapor-pressure (Pa) + relhum, & ! Relative humidity + cld_mr, & ! Total cloud mixing ratio + alpha ! Scheme parameter (default=100) + + ! Outputs + real(kind_phys) :: cld_frac_XuRandall + + ! Locals + real(kind_phys) :: clwt, clwm, onemrh, tem1, tem2, tem3 + + ! Parameters + real(kind_phys) :: & + lambda = 0.50, & ! + P = 0.25 + + clwt = 1.0e-6 * (p_lay*0.001) + if (cld_mr > clwt) then + onemrh = max(1.e-10, 1.0 - relhum) + tem1 = alpha / min(max((onemrh*qs_lay)**lambda,0.0001),1.0) + tem2 = max(min(tem1*(cld_mr - clwt), 50.0 ), 0.0 ) + tem3 = sqrt(sqrt(relhum)) ! This assumes "p" = 0.25. Identical, but cheaper than relhum**p + ! + cld_frac_XuRandall = max( tem3*(1.0-exp(-tem2)), 0.0 ) + else + cld_frac_XuRandall = 0.0 + endif + + return + end function + + ! ###################################################################################### + ! ###################################################################################### + subroutine update_reff(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & + i_cldliq_nc, i_twa, q_lay, p_lay, t_lay, tracer, con_eps, con_rd, ltaerosol, & + effrin_cldliq, effrin_cldice, effrin_cldsnow) + + implicit none + + ! Inputs + integer, intent(in) :: nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & + i_cldliq_nc, i_twa + logical, intent(in) :: ltaerosol + real(kind_phys), intent(in) :: con_eps,con_rd + real(kind_phys), dimension(:,:),intent(in) :: q_lay, p_lay, t_lay + real(kind_phys), dimension(:,:,:),intent(in) :: tracer + + ! Outputs + real(kind_phys), dimension(:,:), intent(inout) :: effrin_cldliq, effrin_cldice, & + effrin_cldsnow + + ! Local + integer :: iCol, iLay + real(kind_phys) :: rho, orho + real(kind_phys),dimension(nCol,nLev) :: qv_mp, qc_mp, qi_mp, qs_mp, ni_mp, nc_mp, & + nwfa, re_cloud, re_ice, re_snow + + ! Prepare cloud mixing-ratios and number concentrations for calc_effectRa + do iLay = 1, nLev + do iCol = 1, nCol + qv_mp(iCol,iLay) = q_lay(iCol,iLay)/(1.-q_lay(iCol,iLay)) + rho = con_eps*p_lay(iCol,iLay)/(con_rd*t_lay(iCol,iLay)*(qv_mp(iCol,iLay)+con_eps)) + orho = 1./rho + qc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq) / (1.-q_lay(iCol,iLay)) + qi_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice) / (1.-q_lay(iCol,iLay)) + qs_mp(iCol,iLay) = tracer(iCol,iLay,i_cldsnow) / (1.-q_lay(iCol,iLay)) + ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) + if (ltaerosol) then + nc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq_nc) / (1.-q_lay(iCol,iLay)) + nwfa(iCol,iLay) = tracer(iCol,iLay,i_twa) + if (qc_mp(iCol,iLay) > 1.e-12 .and. nc_mp(iCol,iLay) < 100.) then + nc_mp(iCol,iLay) = make_DropletNumber(qc_mp(iCol,iLay)*rho, nwfa(iCol,iLay)*rho) * orho + endif + else + nc_mp(iCol,iLay) = nt_c*orho + endif + if (qi_mp(iCol,iLay) > 1.e-12 .and. ni_mp(iCol,iLay) < 100.) then + ni_mp(iCol,iLay) = make_IceNumber(qi_mp(iCol,iLay)*rho, t_lay(iCol,iLay)) * orho + endif + enddo + enddo + + ! Compute effective radii for liquid/ice/snow. + do iCol=1,nCol + call calc_effectRad (t_lay(iCol,:), p_lay(iCol,:), qv_mp(iCol,:), qc_mp(iCol,:), & + nc_mp(iCol,:), qi_mp(iCol,:), ni_mp(iCol,:), qs_mp(iCol,:), & + re_cloud(iCol,:), re_ice(iCol,:), re_snow(iCol,:), 1, nLev ) + do iLay = 1, nLev + re_cloud(iCol,iLay) = MAX(re_qc_min, MIN(re_cloud(iCol,iLay), re_qc_max)) + re_ice(iCol,iLay) = MAX(re_qi_min, MIN(re_ice(iCol,iLay), re_qi_max)) + re_snow(iCol,iLay) = MAX(re_qs_min, MIN(re_snow(iCol,iLay), re_qs_max)) + enddo + enddo + + ! Scale to microns. + do iLay = 1, nLev + do iCol = 1, nCol + effrin_cldliq(iCol,iLay) = re_cloud(iCol,iLay)*1.e6 + effrin_cldice(iCol,iLay) = re_ice(iCol,iLay)*1.e6 + effrin_cldsnow(iCol,iLay) = re_snow(iCol,iLay)*1.e6 + enddo + enddo + + end subroutine update_reff + +end module GFS_rrtmgp_cloud_mp diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta new file mode 100644 index 000000000..2e2037445 --- /dev/null +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -0,0 +1,580 @@ +[ccpp-table-properties] + name = GFS_rrtmgp_cloud_mp + type = scheme + dependencies = radiation_tools.F90, radiation_cloud_overlap.F90, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90, rrtmgp_lw_cloud_optics.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_rrtmgp_cloud_mp_run + type = scheme +[nCol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nLev] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[nTracers] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[ncnd] + standard_name = number_of_condensate_species + long_name = number of cloud condensate types + units = count + dimensions = () + type = integer + intent = in +[icloud] + standard_name = control_for_cloud_area_fraction_option + long_name = cloud effect to the optical depth and cloud fraction in radiation + units = flag + dimensions = () + type = integer + intent = in +[i_cldliq] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[i_cldice] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[i_cldrain] + standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in +[i_cldsnow] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in +[i_cldgrpl] + standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in +[i_cldtot] + standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in +[i_cldliq_nc] + standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array + long_name = tracer index for liquid number concentration + units = index + dimensions = () + type = integer + intent = in +[i_cldice_nc] + standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array + long_name = tracer index for ice number concentration + units = index + dimensions = () + type = integer + intent = in +[i_twa] + standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array + long_name = tracer index for water friendly aerosol + units = index + dimensions = () + type = integer + intent = in +[doSWrad] + standard_name = flag_for_calling_shortwave_radiation + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = in +[doLWrad] + standard_name = flag_for_calling_longwave_radiation + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in +[effr_in] + standard_name = flag_for_cloud_effective_radii + long_name = flag for cloud effective radii calculations in GFDL microphysics + units = flag + dimensions = () + type = logical + intent = in +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_thompson] + standard_name = identifier_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_gfdl] + standard_name = identifier_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr] + standard_name = identifier_for_zhao_carr_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr_pdf] + standard_name = identifier_for_zhao_carr_pdf_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme with PDF clouds + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_mg] + standard_name = identifier_for_morrison_gettelman_microphysics_scheme + long_name = choice of Morrison-Gettelman microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_wsm6] + standard_name = identifier_for_wsm6_microphysics_scheme + long_name = choice of WSM6 microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_fer_hires] + standard_name = identifier_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + 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 +[uni_cld] + standard_name = flag_for_shoc_cloud_area_fraction_for_radiation + long_name = flag for uni_cld + units = flag + dimensions = () + type = logical + intent = in +[lmfdeep2] + standard_name = flag_for_scale_aware_mass_flux_deep_convection_for_radiation + long_name = flag for some scale-aware mass-flux convection scheme active + units = flag + dimensions = () + type = logical + intent = in +[lmfshal] + standard_name = flag_for_cloud_area_fraction_option_for_radiation + long_name = flag for lmfshal + units = flag + dimensions = () + type = logical + intent = in +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics + units = flag + dimensions = () + type = logical + intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_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 +[lgfdlmprad] + standard_name = flag_for_GFDL_microphysics_radiation_interaction + long_name = flag for GFDL microphysics-radiation interaction + units = flag + dimensions = () + type = logical + intent = in +[lsmask] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[p_lev] + standard_name = air_pressure_at_interface_for_RRTMGP + long_name = air pressure at vertical interface for radiation calculation + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[p_lay] + standard_name = air_pressure_at_layer_for_RRTMGP + long_name = air pressure at vertical layer for radiation calculation + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[tv_lay] + standard_name = virtual_temperature + long_name = layer virtual temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[t_lay] + standard_name = air_temperature_at_layer_for_RRTMGP + long_name = air temperature at vertical layer for radiation calculation + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qs_lay] + standard_name = saturation_vapor_pressure + long_name = saturation vapor pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[q_lay] + standard_name = water_vapor_mixing_ratio + long_name = water vaport mixing ratio + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[relhum] + standard_name = relative_humidity + long_name = layer relative humidity + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[effrin_cldliq] + standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle + long_name = eff. radius of cloud liquid water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[effrin_cldice] + standard_name = effective_radius_of_stratiform_cloud_ice_particle + long_name = eff. radius of cloud ice water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[effrin_cldrain] + standard_name = effective_radius_of_stratiform_cloud_rain_particle + long_name = effective radius of cloud rain particle in micrometers + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[effrin_cldsnow] + standard_name = effective_radius_of_stratiform_cloud_snow_particle + long_name = effective radius of cloud snow particle in micrometers + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[tracer] + standard_name = chemical_tracers + long_name = chemical tracers + units = g g-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[cnv_mixratio] + standard_name = convective_cloud_condensate_mixing_ratio + long_name = convective cloud water mixing ratio in the phy_f3d array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cnv_cldfrac] + standard_name = convective_cloud_area_fraction + long_name = convective cloud cover in the phy_f3d array + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qci_conv] + standard_name = convective_cloud_condesate_after_rainout + long_name = convective cloud condesate after rainout + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_ttp] + standard_name = triple_point_temperature_of_water + long_name = triple point temperature of water + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[doGP_cldoptics_PADE] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[doGP_cldoptics_LUT] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[cld_frac] + standard_name = total_cloud_fraction + long_name = layer total cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_lwp] + standard_name = cloud_liquid_water_path + long_name = layer cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_reliq] + standard_name = mean_effective_radius_for_liquid_cloud + long_name = mean effective radius for liquid cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_iwp] + standard_name = cloud_ice_water_path + long_name = layer cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_reice] + standard_name = mean_effective_radius_for_ice_cloud + long_name = mean effective radius for ice cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_swp] + standard_name = cloud_snow_water_path + long_name = layer cloud snow water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_resnow] + standard_name = mean_effective_radius_for_snow_flake + long_name = mean effective radius for snow cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_rwp] + standard_name = cloud_rain_water_path + long_name = layer cloud rain water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_rerain] + standard_name = mean_effective_radius_for_rain_drop + long_name = mean effective radius for rain cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[precip_frac] + standard_name = precipitation_fraction_by_layer + long_name = precipitation fraction in each layer + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cnv_cld_lwp] + standard_name = convective_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cnv_cld_iwp] + standard_name = convective_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cnv_cld_reliq] + standard_name = mean_effective_radius_for_liquid_convective_cloud + long_name = mean effective radius for liquid convective cloud + units = um + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = inout +[cnv_cld_reice] + standard_name = mean_effective_radius_for_ice_convective_cloud + long_name = mean effective radius for ice convective cloud + units = um + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = inout +[lwp_ex] + standard_name = liq_water_path_from_microphysics + long_name = total liquid water path from explicit microphysics + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[iwp_ex] + standard_name = ice_water_path_from_microphysics + long_name = total ice water path from explicit microphysics + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[lwp_fc] + standard_name = liq_water_path_from_cloud_fraction + long_name = total liquid water path from cloud fraction scheme + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[iwp_fc] + standard_name = ice_water_path_from_cloud_fraction + long_name = total ice water path from cloud fraction scheme + units = kg m-2 + 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 From f46396fe334443b00a5a83bf23ac41c626feb136 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 25 Feb 2022 20:17:35 +0000 Subject: [PATCH 075/217] Add explict treatment of convective cloud to RRTMGP. --- physics/GFS_rrtmgp_cloud_mp.F90 | 70 +++++++----- physics/GFS_rrtmgp_cloud_mp.meta | 7 ++ ...p_pre.F90 => GFS_rrtmgp_cloud_overlap.F90} | 68 ++++++++---- ...pre.meta => GFS_rrtmgp_cloud_overlap.meta} | 34 +++++- physics/rrtmgp_lw_cloud_optics.F90 | 69 ++++++++---- physics/rrtmgp_lw_cloud_optics.meta | 46 ++++++++ physics/rrtmgp_lw_cloud_sampling.F90 | 81 ++++++++++---- physics/rrtmgp_lw_cloud_sampling.meta | 44 ++++++++ physics/rrtmgp_lw_rte.F90 | 25 +++-- physics/rrtmgp_lw_rte.meta | 21 ++++ physics/rrtmgp_sw_cloud_optics.F90 | 71 ++++++++---- physics/rrtmgp_sw_cloud_optics.meta | 46 ++++++++ physics/rrtmgp_sw_cloud_sampling.F90 | 105 ++++++++++-------- physics/rrtmgp_sw_cloud_sampling.meta | 44 ++++++++ physics/rrtmgp_sw_rte.F90 | 69 +++++++----- physics/rrtmgp_sw_rte.meta | 21 ++++ 16 files changed, 620 insertions(+), 201 deletions(-) rename physics/{GFS_rrtmgp_cloud_overlap_pre.F90 => GFS_rrtmgp_cloud_overlap.F90} (75%) rename physics/{GFS_rrtmgp_cloud_overlap_pre.meta => GFS_rrtmgp_cloud_overlap.meta} (86%) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index f3444464a..601c2ed0a 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -1,4 +1,4 @@ -! ######################################################################################## +! ###########update_############################################################################# ! ######################################################################################## module GFS_rrtmgp_cloud_mp use machine, only: kind_phys @@ -39,11 +39,13 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic imfdeepcnv, imfdeepcnv_gf, doSWrad, doLWrad, effr_in, lmfshal, ltaerosol, icloud, & imp_physics, imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, lgfdlmprad, & - imp_physics_fer_hires, do_mynnedmf, uni_cld, lmfdeep2, p_lev, p_lay, t_lay, qs_lay, q_lay, relhum, & - lsmask, tv_lay, effrin_cldliq, effrin_cldice, effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cnv_cldfrac, qci_conv, & - con_g, con_rd, con_eps, con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & + imp_physics_fer_hires, do_mynnedmf, uni_cld, lmfdeep2, doGP_convcld, p_lev, & + p_lay, t_lay, qs_lay, q_lay, relhum, lsmask, tv_lay, effrin_cldliq, effrin_cldice,& + effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cnv_cldfrac, qci_conv, & + con_g, con_rd, con_eps, con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice, lwp_ex, iwp_ex, lwp_fc, iwp_fc, errmsg, errflg) + cld_rerain, precip_frac, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice, & + lwp_ex, iwp_ex, lwp_fc, iwp_fc, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -82,6 +84,7 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic do_mynnedmf, & ! Flag to activate MYNN-EDMF uni_cld, & ! Flag for unified cloud scheme lmfdeep2, & ! Flag for mass flux deep convection + doGP_convcld, & ! Treat convective clouds seperately? doGP_cldoptics_LUT, & ! Flag to do GP cloud-optics (LUTs) doGP_cldoptics_PADE ! (PADE approximation) real(kind_phys), intent(in) :: & @@ -147,6 +150,9 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic errmsg = '' errflg = 0 + ! ################################################################################### + ! GFDL Microphysics + ! ################################################################################### if (imp_physics == imp_physics_gfdl) then if (.not. lgfdlmprad) then ! Call progcld_gfdl_lin @@ -171,19 +177,22 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic enddo enddo - call cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & - i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, p_lev, p_lay, t_lay, & - tv_lay, effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, con_g, con_rd, & - con_ttp, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, & - cld_rwp, cld_rerain, effrin_cldrain=effrin_cldrain) + call cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & + i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, p_lev, p_lay, & + t_lay, tv_lay, effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, & + con_g, con_rd, con_ttp, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice,& + cld_swp, cld_resnow, cld_rwp, cld_rerain, effrin_cldrain=effrin_cldrain) end if endif - ! + + ! ################################################################################### + ! Thompson Microphysics + ! ################################################################################### if (imp_physics == imp_physics_thompson) then ! Update particle size using modified mixing-ratios. - call update_reff(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, i_cldliq_nc, & - i_twa, q_lay, p_lay, t_lay, tracer, con_eps, con_rd, ltaerosol, effrin_cldliq, & - effrin_cldice, effrin_cldsnow) + call cmp_reff_Thompson(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & + i_cldliq_nc, i_twa, q_lay, p_lay, t_lay, tracer, con_eps, con_rd, ltaerosol,& + effrin_cldliq, effrin_cldice, effrin_cldsnow) cld_reliq = effrin_cldliq cld_reice = effrin_cldice cld_resnow = effrin_cldsnow @@ -192,25 +201,30 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic if (icloud == 3) then ! Call progcld_thompson else - call cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & - i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, p_lev, p_lay, t_lay, & - tv_lay, effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, con_g, con_rd, & - con_ttp, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, & - cld_resnow, cld_rwp, cld_rerain) + call cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & + i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, & + p_lev, p_lay, t_lay, tv_lay, effrin_cldliq, effrin_cldice, & + effrin_cldsnow, tracer, con_g, con_rd, con_ttp, cld_frac, cld_lwp, & + cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & + cld_rerain) endif else if (icloud == 3) then ! Call progcld_thompson else ! - call cloud_mp_convective(nCol, nLev, t_lay, p_lev, cnv_mixratio, cnv_cldfrac, & - con_ttp, con_g, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice) + if (doGP_convcld) then + call cloud_mp_convective(nCol, nLev, t_lay, p_lev, cnv_mixratio, & + cnv_cldfrac, con_ttp, con_g, cnv_cld_lwp, cnv_cld_reliq, & + cnv_cld_iwp, cnv_cld_reice) + endif ! - call cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & - i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, p_lev, & - p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, relhum, con_g, con_rd, con_eps, & - lmfshal, ltaerosol, imfdeepcnv, imfdeepcnv_gf, uni_cld, lmfdeep2, & - lwp_ex, iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp, cld_iwp, cld_swp, cld_rwp) + call cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & + i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, & + i_twa, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, relhum, & + con_g, con_rd, con_eps, lmfshal, ltaerosol, imfdeepcnv, imfdeepcnv_gf,& + uni_cld, lmfdeep2, lwp_ex, iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp, & + cld_iwp, cld_swp, cld_rwp) endif endif endif @@ -596,7 +610,7 @@ function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) ! ###################################################################################### ! ###################################################################################### - subroutine update_reff(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & + subroutine cmp_reff_Thompson(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & i_cldliq_nc, i_twa, q_lay, p_lay, t_lay, tracer, con_eps, con_rd, ltaerosol, & effrin_cldliq, effrin_cldice, effrin_cldsnow) @@ -666,6 +680,6 @@ subroutine update_reff(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, enddo enddo - end subroutine update_reff + end subroutine cmp_reff_Thompson end module GFS_rrtmgp_cloud_mp diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index 2e2037445..d2eb9c40c 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -245,6 +245,13 @@ dimensions = () type = logical intent = in +[doGP_convcld] + standard_name = flag_to_include_convective_cloud_in_RRTMGP + long_name = logical flag to control convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in [lsmask] standard_name = area_type long_name = landmask: sea/land/ice=0/1/2 diff --git a/physics/GFS_rrtmgp_cloud_overlap_pre.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 similarity index 75% rename from physics/GFS_rrtmgp_cloud_overlap_pre.F90 rename to physics/GFS_rrtmgp_cloud_overlap.F90 index f85621d8f..1b3783407 100644 --- a/physics/GFS_rrtmgp_cloud_overlap_pre.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -1,29 +1,30 @@ ! ######################################################################################## ! ! ######################################################################################## -module GFS_rrtmgp_cloud_overlap_pre +module GFS_rrtmgp_cloud_overlap use machine, only: kind_phys use radiation_tools, only: check_error_msg use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exp - public GFS_rrtmgp_cloud_overlap_pre_init, GFS_rrtmgp_cloud_overlap_pre_run, GFS_rrtmgp_cloud_overlap_pre_finalize + public GFS_rrtmgp_cloud_overlap_init, GFS_rrtmgp_cloud_overlap_run, GFS_rrtmgp_cloud_overlap_finalize contains ! ###################################################################################### ! ###################################################################################### - subroutine GFS_rrtmgp_cloud_overlap_pre_init() - end subroutine GFS_rrtmgp_cloud_overlap_pre_init + subroutine GFS_rrtmgp_cloud_overlap_init() + end subroutine GFS_rrtmgp_cloud_overlap_init ! ###################################################################################### ! ###################################################################################### -!! \section arg_table_GFS_rrtmgp_cloud_overlap_pre_run -!! \htmlinclude GFS_rrtmgp_cloud_overlap_pre_run.html +!! \section arg_table_GFS_rrtmgp_cloud_overlap_run +!! \htmlinclude GFS_rrtmgp_cloud_overlap_run.html !! - subroutine GFS_rrtmgp_cloud_overlap_pre_run(nCol, nLev, yearlen, doSWrad, doLWrad, & + subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, & julian, lat, p_lev, p_lay, tv_lay, con_pi, con_g, con_rd, con_epsq, dcorr_con, & idcor, iovr, iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, idcor_hogan, & - idcor_oreopoulos, cld_frac, top_at_1, & - de_lgth, cloud_overlap_param, precip_overlap_param, deltaZc, errmsg, errflg) + idcor_oreopoulos, cld_frac, cnv_cldfrac, iovr_convcld, top_at_1, doGP_convcld, & + de_lgth, cloud_overlap_param, cnv_cloud_overlap_param, precip_overlap_param, & + deltaZc, errmsg, errflg) implicit none ! Inputs @@ -32,6 +33,7 @@ subroutine GFS_rrtmgp_cloud_overlap_pre_run(nCol, nLev, yearlen, doSWrad, doLWra nLev, & ! Number of vertical layers yearlen, & ! Length of current year (365/366) WTF? iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap method iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method iovr_exp, & ! Flag for exponential cloud overlap method iovr_exprand, & ! Flag for exponential-random cloud overlap method @@ -41,6 +43,7 @@ subroutine GFS_rrtmgp_cloud_overlap_pre_run(nCol, nLev, yearlen, doSWrad, doLWra idcor_oreopoulos ! Flag for decorrelation-length. (10.5194/acp-12-9097-2012) logical, intent(in) :: & top_at_1, & ! Vertical ordering flag + doGP_convcld, & ! Compute overlap parameter for convective cloud? doSWrad, & ! Call SW radiation? doLWrad ! Call LW radiation real(kind_phys), intent(in) :: & @@ -55,21 +58,23 @@ subroutine GFS_rrtmgp_cloud_overlap_pre_run(nCol, nLev, yearlen, doSWrad, doLWra real(kind_phys), dimension(:,:), intent(in) :: & tv_lay, & ! Virtual temperature (K) p_lay, & ! Pressure at model-layers (Pa) - cld_frac ! Total cloud fraction + cld_frac, & ! Total cloud fraction + cnv_cldfrac ! Convective cloud-fraction real(kind_phys), dimension(:,:), intent(in) :: & p_lev ! Pressure at model-level interfaces (Pa) ! Outputs real(kind_phys), dimension(:),intent(out) :: & - de_lgth ! Decorrelation length + de_lgth ! Decorrelation length real(kind_phys), dimension(:,:),intent(out) :: & - cloud_overlap_param, & ! Cloud-overlap parameter - precip_overlap_param, & ! Precipitation overlap parameter - deltaZc ! Layer thickness (from layer-centers)(km) + cloud_overlap_param, & ! Cloud-overlap parameter + cnv_cloud_overlap_param,& ! Convective cloud-overlap parameter + precip_overlap_param, & ! Precipitation overlap parameter + deltaZc ! Layer thickness (from layer-centers)(km) character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag ! Local variables real(kind_phys) :: tem1,pfac @@ -168,15 +173,36 @@ subroutine GFS_rrtmgp_cloud_overlap_pre_run(nCol, nLev, yearlen, doSWrad, doLWra enddo endif + ! + ! Convective cloud overlap parameter + ! + if (doGP_convcld) then + if (iovr_convcld == iovr_dcorr .or. iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then + call get_alpha_exp(nCol, nLev, deltaZc, de_lgth, cnv_cloud_overlap_param) + else + de_lgth(:) = 0. + cnv_cloud_overlap_param(:,:) = 0. + endif + if (iovr_convcld == iovr_exprand) then + do iLay = 1, nLev + do iCol = 1, nCol + if (cnv_cldfrac(iCol,iLay) .eq. 0. .and. cnv_cldfrac(iCol,iLay-1) .gt. 0.) then + cnv_cloud_overlap_param(iCol,iLay) = 0._kind_phys + endif + enddo + enddo + endif + endif + ! ! Compute precipitation overlap parameter (Hack. Using same as cloud for now) ! precip_overlap_param = cloud_overlap_param - end subroutine GFS_rrtmgp_cloud_overlap_pre_run + end subroutine GFS_rrtmgp_cloud_overlap_run ! ######################################################################################### ! ######################################################################################### - subroutine GFS_rrtmgp_cloud_overlap_pre_finalize() - end subroutine GFS_rrtmgp_cloud_overlap_pre_finalize -end module GFS_rrtmgp_cloud_overlap_pre + subroutine GFS_rrtmgp_cloud_overlap_finalize() + end subroutine GFS_rrtmgp_cloud_overlap_finalize +end module GFS_rrtmgp_cloud_overlap diff --git a/physics/GFS_rrtmgp_cloud_overlap_pre.meta b/physics/GFS_rrtmgp_cloud_overlap.meta similarity index 86% rename from physics/GFS_rrtmgp_cloud_overlap_pre.meta rename to physics/GFS_rrtmgp_cloud_overlap.meta index a4620cfa2..1ab6c7ff3 100644 --- a/physics/GFS_rrtmgp_cloud_overlap_pre.meta +++ b/physics/GFS_rrtmgp_cloud_overlap.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = GFS_rrtmgp_cloud_overlap_pre + name = GFS_rrtmgp_cloud_overlap type = scheme dependencies = radiation_tools.F90, radiation_cloud_overlap.F90 ######################################################################## [ccpp-arg-table] - name = GFS_rrtmgp_cloud_overlap_pre_run + name = GFS_rrtmgp_cloud_overlap_run type = scheme [nCol] standard_name = horizontal_loop_extent @@ -136,6 +136,13 @@ dimensions = () type = integer intent = in +[iovr_convcld] + standard_name = flag_for_convective_cloud_overlap_method_for_radiation + long_name = flag for convective cloud overlap method + units = flag + dimensions = () + type = integer + intent = in [iovr_dcorr] standard_name = flag_for_decorrelation_length_cloud_overlap_method long_name = choice of decorrelation-length cloud overlap method @@ -186,6 +193,14 @@ type = real kind = kind_phys intent = in +[cnv_cldfrac] + standard_name = convective_cloud_area_fraction + long_name = convective cloud cover in the phy_f3d array + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [top_at_1] standard_name = flag_for_vertical_ordering_in_RRTMGP long_name = flag for vertical ordering in RRTMGP @@ -193,6 +208,13 @@ dimensions = () type = logical intent = in +[doGP_convcld] + standard_name = flag_to_include_convective_cloud_in_RRTMGP + long_name = logical flag to control convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in [de_lgth] standard_name = cloud_decorrelation_length long_name = cloud decorrelation length @@ -217,6 +239,14 @@ type = real kind = kind_phys intent = out +[cnv_cloud_overlap_param] + standard_name = convective_cloud_overlap_param + long_name = convective cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [deltaZc] standard_name = layer_thickness long_name = layer_thickness diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 5ddcec078..4dfcc1e27 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -383,10 +383,11 @@ end subroutine rrtmgp_lw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, nCol, nLev, nbndsGPlw, & - p_lay, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, & - cld_rwp, cld_rerain, precip_frac, lon, lat, cldtaulw, & - lw_optical_props_cloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) + doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, doGP_convcld, nCol, nLev, & + nbndsGPlw , p_lay, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, & + cld_resnow, cld_rwp, cld_rerain, precip_frac, cnv_cld_lwp, cnv_cld_reliq, & + cnv_cld_iwp, cnv_cld_reice, lon, lat, cldtaulw, lw_optical_props_cloudsByBand, & + lw_optical_props_cnvcloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -394,9 +395,10 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw doG_cldoptics, & ! Use legacy RRTMG cloud-optics? doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? - doGP_lwscat ! Include scattering in LW cloud-optics? + doGP_lwscat, & ! Include scattering in LW cloud-optics? + doGP_convcld ! integer, intent(in) :: & - nbndsGPlw, & ! Number of longwave bands + nbndsGPlw, & ! nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels icliq_lw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) @@ -415,7 +417,11 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw cld_resnow, & ! Cloud snow effective radius cld_rwp, & ! Cloud rain water path cld_rerain, & ! Cloud rain effective radius - precip_frac ! Precipitation fraction by layer. + precip_frac, & ! Precipitation fraction by layer. + cnv_cld_lwp, & ! Water path for convective liquid cloud-particles (microns) + cnv_cld_reliq, & ! Effective radius for convective liquid cloud-particles (microns) + cnv_cld_iwp, & ! Water path for convective ice cloud-particles (microns) + cnv_cld_reice ! Effective radius for convective ice cloud-particles (microns) ! Outputs character(len=*), intent(out) :: & @@ -423,8 +429,9 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw integer, intent(out) :: & errflg ! CCPP error flag type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) - lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) + lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) + lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) + lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) real(kind_phys), dimension(ncol,nLev), intent(inout) :: & cldtaulw ! Approx 10.mu band layer cloud optical depth @@ -444,27 +451,41 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw if (.not. doLWrad) return - lw_optical_props_cloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - lw_optical_props_precipByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + lw_optical_props_cloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + lw_optical_props_cnvcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + lw_optical_props_precipByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() do iBand=1,lw_gas_props%get_nband() - lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_precipByBand%gpt2band(iBand) = iBand - lw_optical_props_precipByBand%gpt2band(iBand) = iBand + lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_cnvcloudsByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_precipByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_cloudsByBand%gpt2band(iBand) = iBand + lw_optical_props_cnvcloudsByBand%gpt2band(iBand) = iBand + lw_optical_props_precipByBand%gpt2band(iBand) = iBand end do ! Compute cloud-optics for RTE. if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - ! i) RRTMGP cloud-optics. - call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_cloud_props%cloud_optics(& - cld_lwp, & ! IN - Cloud liquid water path (g/m2) - cld_iwp, & ! IN - Cloud ice water path (g/m2) - cld_reliq, & ! IN - Cloud liquid effective radius (microns) - cld_reice, & ! IN - Cloud ice effective radius (microns) - lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties - ! in each band - ! Add in rain and snow(+groupel) + ! i) Cloud-optics. + call check_error_msg('rrtmgp_lw_cloud_optics_run - clouds',lw_cloud_props%cloud_optics(& + cld_lwp, & ! IN - Cloud liquid water path (g/m2) + cld_iwp, & ! IN - Cloud ice water path (g/m2) + cld_reliq, & ! IN - Cloud liquid effective radius (microns) + cld_reice, & ! IN - Cloud ice effective radius (microns) + lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties + ! in each band + ! ii) Convective cloud-optics + if (doGP_convcld) then + call check_error_msg('rrtmgp_lw_cnvcloud_optics_run - convective cloud',lw_cloud_props%cloud_optics(& + cnv_cld_lwp, & ! IN - Convective cloud liquid water path (g/m2) + cnv_cld_iwp, & ! IN - Convective cloud ice water path (g/m2) + cnv_cld_reliq, & ! IN - Convective cloud liquid effective radius (microns) + cnv_cld_reice, & ! IN - Convective cloud ice effective radius (microns) + lw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties + ! in each band + endif + + ! iii) Cloud precipitation optics: rain and snow(+groupel) do iCol=1,nCol do iLay=1,nLev if (cld_frac(iCol,iLay) .gt. 0.) then diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index 35e27979e..fcb19fb41 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -141,6 +141,13 @@ dimensions = () type = logical intent = in +[doGP_convcld] + standard_name = flag_to_include_convective_cloud_in_RRTMGP + long_name = logical flag to control convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -235,6 +242,38 @@ type = real kind = kind_phys intent = in +[cnv_cld_lwp] + standard_name = convective_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cnv_cld_iwp] + standard_name = convective_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cnv_cld_reliq] + standard_name = mean_effective_radius_for_liquid_convective_cloud + long_name = mean effective radius for liquid convective cloud + units = um + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = in +[cnv_cld_reice] + standard_name = mean_effective_radius_for_ice_convective_cloud + long_name = mean effective radius for ice convective cloud + units = um + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = in [p_lay] standard_name = air_pressure_at_layer_for_RRTMGP long_name = air pressure layer @@ -281,6 +320,13 @@ dimensions = () type = ty_optical_props_2str intent = inout +[lw_optical_props_cnvcloudsByBand] + standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout [lw_optical_props_precipByBand] standard_name = longwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 index d8d499577..8f4b79b61 100644 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ b/physics/rrtmgp_lw_cloud_sampling.F90 @@ -18,20 +18,24 @@ module rrtmgp_lw_cloud_sampling !! \section arg_table_rrtmgp_lw_cloud_sampling_run !! \htmlinclude rrtmgp_lw_cloud_sampling_run.html !! - subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, & + subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iovr_convcld,& iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, & - cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, & - doGP_lwscat, lw_optical_props_cloudsByBand, lw_optical_props_precipByBand, & - lw_optical_props_clouds, lw_optical_props_precip, errmsg, errflg) + cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, cnv_cldfrac, & + cnv_cloud_overlap_param, doGP_lwscat, doGP_convcld, lw_optical_props_cloudsByBand, & + lw_optical_props_cnvcloudsByBand, lw_optical_props_precipByBand, & + lw_optical_props_clouds, lw_optical_props_cnvclouds, lw_optical_props_precip, & + errmsg, errflg) ! Inputs logical, intent(in) :: & doLWrad, & ! Logical flag for shortwave radiation call - doGP_lwscat ! Include scattering in LW cloud-optics? + doGP_lwscat, & ! Include scattering in LW cloud-optics? + doGP_convcld integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical layers iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap iovr_max, & ! Flag for maximum cloud overlap method iovr_maxrand, & ! Flag for maximum-random cloud overlap method iovr_rand, & ! Flag for random cloud overlap method @@ -46,12 +50,15 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, ! random numbers. when isubc_lw /=2, it will not be used. real(kind_phys), dimension(ncol,nLev),intent(in) :: & cld_frac, & ! Total cloud fraction by layer + cnv_cldfrac, & ! Convective cloud fraction by layer precip_frac ! Precipitation fraction by layer real(kind_phys), dimension(ncol,nLev), intent(in) :: & cloud_overlap_param, & ! Cloud overlap parameter + cnv_cloud_overlap_param, & ! Convective cloud overlap parameter precip_overlap_param ! Precipitation overlap parameter type(ty_optical_props_2str),intent(in) :: & lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) + lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) ! Outputs @@ -61,6 +68,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, errflg ! CCPP error code type(ty_optical_props_2str),intent(inout) :: & lw_optical_props_clouds, & ! RRTMGP DDT: Shortwave optical properties by spectral point (clouds) + lw_optical_props_cnvclouds, & ! RRTMGP DDT: Shortwave optical properties by spectral point (convective cloud) lw_optical_props_precip ! RRTMGP DDT: Shortwave optical properties by spectral point (precipitation) ! Local variables @@ -70,7 +78,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, real(kind_phys), dimension(lw_gas_props%get_ngpt(),nLev,ncol) :: rng3D,rng3D2 real(kind_phys), dimension(lw_gas_props%get_ngpt()*nLev) :: rng2D real(kind_phys), dimension(lw_gas_props%get_ngpt()) :: rng1D - logical, dimension(ncol,nLev,lw_gas_props%get_ngpt()) :: cldfracMCICA,precipfracSAMP + logical, dimension(ncol,nLev,lw_gas_props%get_ngpt()) :: maskMCICA ! Initialize CCPP error handling variables errmsg = '' @@ -119,7 +127,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, ! Cloud-overlap. ! Maximum-random, random or maximum. if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, cld_frac, cldfracMCICA) + call sampled_mask(rng3D, cld_frac, maskMCICA) endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then @@ -129,13 +137,13 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, call random_number(rng2D,rng_stat) rng3D2(:,:,iCol) = reshape(source = rng2D,shape=[lw_gas_props%get_ngpt(),nLev]) enddo - call sampled_mask(rng3D, cld_frac, cldfracMCICA, & + call sampled_mask(rng3D, cld_frac, maskMCICA, & overlap_param = cloud_overlap_param(:,1:nLev-1), & randoms2 = rng3D2) endif ! Exponential or Exponential-random if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac, cldfracMCICA, & + call sampled_mask(rng3D, cld_frac, maskMCICA, & overlap_param = cloud_overlap_param(:,1:nLev-1)) endif @@ -143,10 +151,48 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_lw_cloud_sampling_run_draw_samples',& - draw_samples(cldfracMCICA, doGP_lwscat, & + draw_samples(maskMCICA, doGP_lwscat, & lw_optical_props_cloudsByBand, & lw_optical_props_clouds)) + ! #################################################################################### + ! Convective cloud ... + ! (Use same RNGs as was used by the clouds.) + ! #################################################################################### + if (doGP_convcld) then + lw_optical_props_cnvclouds%band2gpt = lw_gas_props%get_band_lims_gpoint() + lw_optical_props_cnvclouds%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_cnvclouds%gpt2band(lw_optical_props_cnvclouds%band2gpt(1,iBand):& + lw_optical_props_cnvclouds%band2gpt(2,iBand)) = iBand + end do + + ! Convective cloud overlap + ! Maximum-random, random or maximum. + if (iovr_convcld == iovr_maxrand .or. iovr_convcld == iovr_rand .or. iovr_convcld == iovr_max) then + call sampled_mask(rng3D, cnv_cldfrac, maskMCICA) + endif + ! Exponential decorrelation length overlap + if (iovr_convcld == iovr_dcorr) then + call sampled_mask(rng3D, cnv_cldfrac, maskMCICA, & + overlap_param = cnv_cloud_overlap_param(:,1:nLev-1), & + randoms2 = rng3D2) + endif + ! Exponential or Exponential-random + if (iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then + call sampled_mask(rng3D, cnv_cldfrac, maskMCICA, & + overlap_param = cnv_cloud_overlap_param(:,1:nLev-1)) + endif + + ! + ! Sampling. Map band optical depth to each g-point using McICA + ! + call check_error_msg('rrtmgp_lw_cnvcloud_sampling_run_draw_samples',& + draw_samples(maskMCICA, doGP_lwscat, & + lw_optical_props_cnvcloudsByBand, & + lw_optical_props_cnvclouds)) + endif + ! #################################################################################### ! Next sample the precipitation... ! (Use same RNGs as was used by the clouds.) @@ -160,17 +206,17 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, ! Precipitation overlap. ! Maximum-random, random or maximum. if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, precip_frac, precipfracSAMP) + call sampled_mask(rng3D, precip_frac, maskMCICA) endif - ! Exponential decorrelation length overlap + ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then - call sampled_mask(rng3D, precip_frac, precipfracSAMP, & + call sampled_mask(rng3D, precip_frac, maskMCICA, & overlap_param = precip_overlap_param(:,1:nLev-1), & randoms2 = rng3D2) endif ! Exponential or Exponential-random if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, precip_frac, precipfracSAMP, & + call sampled_mask(rng3D, precip_frac, maskMCICA, & overlap_param = precip_overlap_param(:,1:nLev-1)) endif @@ -178,14 +224,9 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_lw_precip_sampling_run_draw_samples',& - draw_samples(precipfracSAMP, doGP_lwscat, & + draw_samples(maskMCICA, doGP_lwscat, & lw_optical_props_precipByBand, & lw_optical_props_precip)) - - ! #################################################################################### - ! Just add precipitation optics to cloud-optics - ! #################################################################################### - lw_optical_props_clouds%tau = lw_optical_props_clouds%tau + lw_optical_props_precip%tau end subroutine rrtmgp_lw_cloud_sampling_run diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta index 2e4029ae2..b68a85b0a 100644 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ b/physics/rrtmgp_lw_cloud_sampling.meta @@ -21,6 +21,20 @@ dimensions = () type = logical intent = in +[doGP_convcld] + standard_name = flag_to_include_convective_cloud_in_RRTMGP + long_name = logical flag to control convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[iovr_convcld] + standard_name = flag_for_convective_cloud_overlap_method_for_radiation + long_name = flag for convective cloud overlap method + units = flag + dimensions = () + type = integer + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -106,6 +120,14 @@ type = real kind = kind_phys intent = in +[cnv_cldfrac] + standard_name = convective_cloud_area_fraction + long_name = convective cloud cover in the phy_f3d array + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [precip_frac] standard_name = precipitation_fraction_by_layer long_name = precipitation fraction in each layer @@ -122,6 +144,14 @@ type = real kind = kind_phys intent = in +[cnv_cloud_overlap_param] + standard_name = convective_cloud_overlap_param + long_name = convective cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [precip_overlap_param] standard_name = precip_overlap_param long_name = precipitation overlap parameter @@ -137,6 +167,13 @@ dimensions = () type = ty_optical_props_2str intent = in +[lw_optical_props_cnvcloudsByBand] + standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in [lw_optical_props_precipByBand] standard_name = longwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties @@ -158,6 +195,13 @@ dimensions = () type = ty_optical_props_2str intent = inout +[lw_optical_props_cnvclouds] + standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index aed4f0027..c4272b982 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -26,10 +26,11 @@ end subroutine rrtmgp_lw_rte_init !! \htmlinclude rrtmgp_lw_rte_run.html !! subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & - nLev, top_at_1, sfc_emiss_byband, sources, lw_optical_props_clrsky, & - lw_optical_props_clouds, lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, & - fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, & - fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg) + nLev, top_at_1, doGP_convcld, sfc_emiss_byband, sources, lw_optical_props_clrsky, & + lw_optical_props_clouds, lw_optical_props_precip, lw_optical_props_cnvclouds, & + lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, fluxlwDOWN_allsky, & + fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwUP_radtime, & + fluxlwDOWN_radtime, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -37,6 +38,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, doLWrad, & ! Logical flag for longwave radiation call doLWclrsky, & ! Compute clear-sky fluxes for clear-sky heating-rate? use_LW_jacobian, & ! Compute Jacobian of LW to update radiative fluxes between radiation calls? + doGP_convcld, & ! Flag to include convective cloud doGP_lwscat ! Include scattering in LW cloud-optics? integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints @@ -50,8 +52,9 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, lw_optical_props_aerosol, &! RRTMGP DDT: longwave aerosol radiative properties lw_optical_props_clrsky ! RRTMGP DDT: longwave clear-sky radiative properties type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_clouds ! RRTMGP DDT: longwave cloud radiative properties - + lw_optical_props_clouds, &! RRTMGP DDT: longwave cloud radiative properties + lw_optical_props_precip, &! RRTMGP DDT: longwave precipitation radiative properties + lw_optical_props_cnvclouds ! RRTMGP DDT: longwave convective cloud radiative properties ! Outputs real(kind_phys), dimension(ncol,nLev+1), intent(inout) :: & fluxlwUP_jac, & ! Jacobian of upwelling LW surface radiation (W/m2/K) @@ -121,9 +124,17 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, endif ! - ! All-sky fluxes + ! All-sky fluxes (clear-sky + clouds + precipitation) ! + ! Include convective cloud? + if (doGP_convcld) then + call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_cnvclouds%increment(lw_optical_props_clrsky)) + endif + + ! Add in precipitation + call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_precip%increment(lw_optical_props_clouds)) + ! Include LW cloud-scattering? if (doGP_lwscat) then ! Add clear-sky optics to cloud-optics (2-stream) diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 069537964..194ef725d 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -36,6 +36,13 @@ dimensions = () type = logical intent = in +[doGP_convcld] + standard_name = flag_to_include_convective_cloud_in_RRTMGP + long_name = logical flag to control convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -86,6 +93,20 @@ dimensions = () type = ty_optical_props_2str intent = inout +[lw_optical_props_precip] + standard_name = longwave_optical_properties_for_precipitation + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout +[lw_optical_props_cnvclouds] + standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout [lw_optical_props_aerosol] standard_name = longwave_optical_properties_for_aerosols long_name = Fortran DDT containing RRTMGP optical properties diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index f80440522..01db38374 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -395,9 +395,10 @@ end subroutine rrtmgp_sw_cloud_optics_init !! \htmlinclude rrtmgp_sw_cloud_optics.html !! subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, nCol, nLev, nDay, nbndsGPsw, idxday, & - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, sw_optical_props_cloudsByBand, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_convcld, nCol, nLev, nDay, nbndsGPsw, & + idxday, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, & + cld_rwp, cld_rerain, precip_frac, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, & + cnv_cld_reice, sw_optical_props_cloudsByBand, sw_optical_props_cnvcloudsByBand, & sw_optical_props_precipByBand, cldtausw, errmsg, errflg) ! Inputs @@ -405,7 +406,8 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw doSWrad, & ! Logical flag for shortwave radiation call doG_cldoptics, & ! Use legacy RRTMG cloud-optics? doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? + doGP_convcld ! integer, intent(in) :: & nbndsGPsw, & ! Number of shortwave bands nCol, & ! Number of horizontal gridpoints @@ -425,18 +427,22 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw cld_resnow, & ! Cloud snow effective radius cld_rwp, & ! Cloud rain water path cld_rerain, & ! Cloud rain effective radius - precip_frac ! Precipitation fraction by layer - + precip_frac, & ! Precipitation fraction by layer + cnv_cld_lwp, & ! Water path for convective liquid cloud-particles (microns) + cnv_cld_reliq, & ! Effective radius for convective liquid cloud-particles (microns) + cnv_cld_iwp, & ! Water path for convective ice cloud-particles (microns) + cnv_cld_reice ! Effective radius for convective ice cloud-particles (microns) ! Outputs character(len=*), intent(out) :: & - errmsg ! CCPP error message + errmsg ! CCPP error message integer, intent(out) :: & - errflg ! CCPP error flag + errflg ! CCPP error flag type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) - sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (cloud precipitation) + sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) + sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (convectivecloud) + sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (cloud precipitation) real(kind_phys), dimension(ncol,NLev), intent(out) :: & - cldtausw ! Approx 10.mu band layer cloud optical depth + cldtausw ! Approx 10.mu band layer cloud optical depth ! Local variables integer :: iDay, iLay, iBand @@ -457,26 +463,43 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw ! Compute cloud/precipitation optics. if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_cloudsByBand%alloc_2str(& - nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cloudsByBand',& + sw_optical_props_cloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) sw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys sw_optical_props_cloudsByBand%ssa(:,:,:) = 1._kind_phys sw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_precipByBand%alloc_2str(& - nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cnvcloudsByBand',& + sw_optical_props_cnvcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + sw_optical_props_cnvcloudsByBand%tau(:,:,:) = 0._kind_phys + sw_optical_props_cnvcloudsByBand%ssa(:,:,:) = 1._kind_phys + sw_optical_props_cnvcloudsByBand%g(:,:,:) = 0._kind_phys + + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_precipByBand',& + sw_optical_props_precipByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys - ! RRTMGP cloud-optics. - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_cloud_props%cloud_optics(& - cld_lwp(idxday(1:nday),:), & ! IN - Cloud liquid water path - cld_iwp(idxday(1:nday),:), & ! IN - Cloud ice water path - cld_reliq(idxday(1:nday),:), & ! IN - Cloud liquid effective radius - cld_reice(idxday(1:nday),:), & ! IN - Cloud ice effective radius - sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) - ! Cloud precipitation optics: rain and snow(+groupel) + ! i) Cloud-optics. + call check_error_msg('rrtmgp_sw_cloud_optics_run - clouds',sw_cloud_props%cloud_optics(& + cld_lwp(idxday(1:nday),:), & ! IN - Cloud liquid water path + cld_iwp(idxday(1:nday),:), & ! IN - Cloud ice water path + cld_reliq(idxday(1:nday),:), & ! IN - Cloud liquid effective radius + cld_reice(idxday(1:nday),:), & ! IN - Cloud ice effective radius + sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + ! ii) Convective cloud-optics + if (doGP_convcld) then + call check_error_msg('rrtmgp_sw_cloud_optics_run - convective clouds',sw_cloud_props%cloud_optics(& + cnv_cld_lwp(idxday(1:nday),:), & ! IN - Convective cloud liquid water path + cnv_cld_iwp(idxday(1:nday),:), & ! IN - Convective cloud ice water path + cnv_cld_reliq(idxday(1:nday),:), & ! IN - Convective cloud liquid effective radius + cnv_cld_reice(idxday(1:nday),:), & ! IN - Convective cloud ice effective radius + sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + endif + + ! iii) Cloud precipitation optics: rain and snow(+groupel) do iDay=1,nDay do iLay=1,nLev if (cld_frac(idxday(iDay),iLay) .gt. 1.e-12_kind_phys) then diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta index d73258cb2..913979f60 100644 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ b/physics/rrtmgp_sw_cloud_optics.meta @@ -147,6 +147,13 @@ dimensions = () type = logical intent = in +[doGP_convcld] + standard_name = flag_to_include_convective_cloud_in_RRTMGP + long_name = logical flag to control convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in [cld_frac] standard_name = total_cloud_fraction long_name = layer total cloud fraction @@ -227,6 +234,38 @@ type = real kind = kind_phys intent = in +[cnv_cld_lwp] + standard_name = convective_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cnv_cld_iwp] + standard_name = convective_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cnv_cld_reliq] + standard_name = mean_effective_radius_for_liquid_convective_cloud + long_name = mean effective radius for liquid convective cloud + units = um + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = in +[cnv_cld_reice] + standard_name = mean_effective_radius_for_ice_convective_cloud + long_name = mean effective radius for ice convective cloud + units = um + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = in [nbndsGPsw] standard_name = number_of_shortwave_bands long_name = number of sw bands used in RRTMGP @@ -255,6 +294,13 @@ dimensions = () type = ty_optical_props_2str intent = out +[sw_optical_props_cnvcloudsByBand] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out [sw_optical_props_precipByBand] standard_name = shortwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 index 3172ae315..6ad6058da 100644 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -19,19 +19,23 @@ module rrtmgp_sw_cloud_sampling !! \htmlinclude rrtmgp_sw_cloud_sampling.html !! subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, & - iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_sw, & - icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, & + iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, & + isubc_sw,icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param,& + doGP_convcld, cnv_cloud_overlap_param, cnv_cldfrac,sw_optical_props_cnvcloudsByBand, & sw_optical_props_cloudsByBand, sw_optical_props_precipByBand, & - sw_optical_props_clouds, sw_optical_props_precip, errmsg, errflg) + sw_optical_props_clouds, sw_optical_props_cnvclouds, sw_optical_props_precip, & + errmsg, errflg) ! Inputs logical, intent(in) :: & + doGP_convcld, & ! doSWrad ! Logical flag for shortwave radiation call integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nDay, & ! Number of daylit points. nLev, & ! Number of vertical layers iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap method iovr_max, & ! Flag for maximum cloud overlap method iovr_maxrand, & ! Flag for maximum-random cloud overlap method iovr_rand, & ! Flag for random cloud overlap method @@ -48,12 +52,15 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, ! random numbers. when isubc_sw /=2, it will not be used. real(kind_phys), dimension(ncol,nLev),intent(in) :: & cld_frac, & ! Total cloud fraction by layer + cnv_cldfrac, & ! Convective cloud fraction by layer precip_frac ! Precipitation fraction by layer real(kind_phys), dimension(ncol,nLev), intent(in) :: & cloud_overlap_param, & ! Cloud overlap parameter + cnv_cloud_overlap_param, & ! Convective cloud overlap parameter precip_overlap_param ! Precipitation overlap parameter type(ty_optical_props_2str),intent(in) :: & sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) + sw_optical_props_cnvcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (convectivecloud) sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (precipitation) ! Outputs @@ -63,6 +70,7 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, errflg ! Error flag type(ty_optical_props_2str),intent(out) :: & sw_optical_props_clouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (clouds) + sw_optical_props_cnvclouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (convectivecloud) sw_optical_props_precip ! RRTMGP DDT: Shortwave optical properties at each spectral point (precipitation) ! Local variables @@ -73,7 +81,7 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLev,nday) :: rng3D,rng3D2 real(kind_phys), dimension(sw_gas_props%get_ngpt()*nLev) :: rng2D real(kind_phys), dimension(sw_gas_props%get_ngpt()) :: rng1D - logical, dimension(nday,nLev,sw_gas_props%get_ngpt()) :: cldfracMCICA,precipfracSAMP + logical, dimension(nday,nLev,sw_gas_props%get_ngpt()) :: maskMCICA ! Initialize CCPP error handling variables errmsg = '' @@ -121,7 +129,7 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, ! Cloud overlap. ! Maximum-random, random, or maximum cloud overlap if (iovr == iovr_maxrand .or. iovr == iovr_max .or. iovr == iovr_rand) then - call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), cldfracMCICA) + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA) endif ! Decorrelation-length overlap if (iovr == iovr_dcorr) then @@ -130,13 +138,13 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, call random_number(rng2D,rng_stat) rng3D2(:,:,iday) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLev]) enddo - call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), cldfracMCICA, & + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA, & overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1),& randoms2 = rng3D2) endif ! Exponential or exponential-random cloud overlap if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), cldfracMCICA, & + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA, & overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1)) endif @@ -144,12 +152,46 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_sw_cloud_sampling_run_draw_samples', & - draw_samples(cldfracMCICA, .true., & + draw_samples(maskMCICA, .true., & sw_optical_props_cloudsByBand, & sw_optical_props_clouds)) - + + ! ################################################################################# + ! Convective cloud... + ! (Use same RNGs as was used by the clouds.) + ! ################################################################################# + if (doGP_convcld) then + + ! Allocate space RRTMGP DDTs [nday,nLev,nGpt] + call check_error_msg('rrtmgp_sw_cnvcloud_sampling_run', & + sw_optical_props_precip%alloc_2str( nday, nLev, sw_gas_props)) + + ! Maximum-random, random or maximum overlap + if (iovr_convcld == iovr_maxrand .or. iovr_convcld == iovr_max .or. iovr_convcld == iovr_rand) then + call sampled_mask(rng3D, cnv_cldfrac(idxday(1:nDay),:), maskMCICA) + endif + ! Exponential decorrelation length overlap + if (iovr_convcld == iovr_dcorr) then + call sampled_mask(rng3D, cnv_cldfrac(idxday(1:nDay),:), maskMCICA, & + overlap_param = cnv_cloud_overlap_param(idxday(1:nDay),1:nLev-1),& + randoms2 = rng3D2) + endif + if (iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then + call sampled_mask(rng3D, cnv_cldfrac(idxday(1:nDay),:), maskMCICA, & + overlap_param = cnv_cloud_overlap_param(idxday(1:nDay),1:nLev-1)) + endif + + ! + ! Sampling. Map band optical depth to each g-point using McICA + ! + call check_error_msg('rrtmgp_sw_cnvcloud_sampling_run_draw_samples', & + draw_samples(maskMCICA, .true., & + sw_optical_props_cnvcloudsByBand, & + sw_optical_props_cnvclouds)) + endif ! ################################################################################# - ! Next sample precipitation (same as clouds for now) + ! Preciptitation... + ! (Use same RNGs as was used by the clouds.) ! ################################################################################# ! Allocate space RRTMGP DDTs [nday,nLev,nGpt] @@ -159,16 +201,16 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, ! Precipitation overlap ! Maximum-random, random or maximum precipitation overlap if (iovr == iovr_maxrand .or. iovr == iovr_max .or. iovr == iovr_rand) then - call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), precipfracSAMP) + call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), maskMCICA) endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then - call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), precipfracSAMP, & + call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), maskMCICA, & overlap_param = precip_overlap_param(idxday(1:nDay),1:nLev-1),& randoms2 = rng3D2) endif if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:),precipfracSAMP, & + call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), maskMCICA, & overlap_param = precip_overlap_param(idxday(1:nDay),1:nLev-1)) endif @@ -176,44 +218,9 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_sw_precip_sampling_run_draw_samples', & - draw_samples(precipfracSAMP, .true., & + draw_samples(maskMCICA, .true., & sw_optical_props_precipByBand, & sw_optical_props_precip)) - - ! ################################################################################# - ! Just add precipitation optics to cloud-optics - ! ################################################################################# - do iGpt=1,sw_gas_props%get_ngpt() - do iday=1,nDay - do iLay=1,nLev - tauloc = sw_optical_props_clouds%tau(iday,iLay,iGpt) + & - sw_optical_props_precip%tau(iday,iLay,iGpt) - if (sw_optical_props_precip%tau(iday,iLay,iGpt) > 0) then - ssaloc = (sw_optical_props_clouds%tau(iday,iLay,iGpt) * & - sw_optical_props_clouds%ssa(iday,iLay,iGpt) + & - sw_optical_props_precip%tau(iday,iLay,iGpt) * & - sw_optical_props_precip%ssa(iday,iLay,iGpt)) / & - tauloc - if (ssaloc > 0) then - asyloc = (sw_optical_props_clouds%tau(iday,iLay,iGpt) * & - sw_optical_props_clouds%ssa(iday,iLay,iGpt) * & - sw_optical_props_clouds%g(iday,iLay,iGpt) + & - sw_optical_props_precip%tau(iday,iLay,iGpt) * & - sw_optical_props_precip%ssa(iday,iLay,iGpt) * & - sw_optical_props_precip%g(iday,iLay,iGpt)) / & - (tauloc*ssaloc) - else - tauloc = sw_optical_props_clouds%tau(iday,iLay,iGpt) - ssaloc = sw_optical_props_clouds%ssa(iday,iLay,iGpt) - asyloc = sw_optical_props_clouds%g(iday,iLay,iGpt) - endif - sw_optical_props_clouds%tau(iday,iLay,iGpt) = tauloc - sw_optical_props_clouds%ssa(iday,iLay,iGpt) = ssaloc - sw_optical_props_clouds%g(iday,iLay,iGpt) = asyloc - endif - enddo - enddo - enddo endif end subroutine rrtmgp_sw_cloud_sampling_run diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta index cda161e81..fb1edd10e 100644 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ b/physics/rrtmgp_sw_cloud_sampling.meta @@ -14,6 +14,20 @@ dimensions = () type = logical intent = in +[doGP_convcld] + standard_name = flag_to_include_convective_cloud_in_RRTMGP + long_name = logical flag to control convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[iovr_convcld] + standard_name = flag_for_convective_cloud_overlap_method_for_radiation + long_name = flag for convective cloud overlap method + units = flag + dimensions = () + type = integer + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -121,6 +135,22 @@ type = real kind = kind_phys intent = in +[cnv_cldfrac] + standard_name = convective_cloud_area_fraction + long_name = convective cloud cover in the phy_f3d array + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cnv_cloud_overlap_param] + standard_name = convective_cloud_overlap_param + long_name = convective cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [cloud_overlap_param] standard_name = cloud_overlap_param long_name = cloud overlap parameter @@ -144,6 +174,13 @@ dimensions = () type = ty_optical_props_2str intent = in +[sw_optical_props_cnvcloudsByBand] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in [sw_optical_props_precipByBand] standard_name = shortwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties @@ -158,6 +195,13 @@ dimensions = () type = ty_optical_props_2str intent = out +[sw_optical_props_cnvclouds] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out [sw_optical_props_precip] standard_name = shortwave_optical_properties_for_precipitation long_name = Fortran DDT containing RRTMGP optical properties diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index 1726d4bbd..0c2ea5288 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -24,41 +24,45 @@ end subroutine rrtmgp_sw_rte_init !! \section arg_table_rrtmgp_sw_rte_run !! \htmlinclude rrtmgp_sw_rte.html !! - subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay, & - t_lay, top_at_1, iSFC, sw_optical_props_clrsky, sfc_alb_nir_dir, sfc_alb_nir_dif, & - sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clouds, & - sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky,& - fluxswDOWN_clrsky, errmsg, errflg) + subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay,& + t_lay, top_at_1, doGP_convcld, iSFC, sfc_alb_nir_dir, sfc_alb_nir_dif, & + sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clrsky, & + sw_optical_props_clouds, sw_optical_props_precip, sw_optical_props_cnvclouds, & + sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, & + fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) ! Inputs logical, intent(in) :: & - top_at_1, & ! Vertical ordering flag - doSWrad, & ! Flag to calculate SW irradiances - doSWclrsky ! Compute clear-sky fluxes? + top_at_1, & ! Vertical ordering flag + doGP_convcld, & ! Flag to include convective cloud + doSWrad, & ! Flag to calculate SW irradiances + doSWclrsky ! Compute clear-sky fluxes? integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nday, & ! Number of daytime points - nLev, & ! Number of vertical levels - iSFC ! Vertical index for surface-level + nCol, & ! Number of horizontal gridpoints + nday, & ! Number of daytime points + nLev, & ! Number of vertical levels + iSFC ! Vertical index for surface-level integer, intent(in), dimension(ncol) :: & - idxday ! Index array for daytime points + idxday ! Index array for daytime points real(kind_phys),intent(in), dimension(ncol) :: & - coszen ! Cosize of SZA + coszen ! Cosize of SZA real(kind_phys), dimension(ncol,NLev), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay ! Temperature (K) + p_lay, & ! Pressure @ model layer-centers (Pa) + t_lay ! Temperature (K) type(ty_optical_props_2str),intent(inout) :: & - sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties + sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties type(ty_optical_props_2str),intent(in) :: & - sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud radiative properties - sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol radiative properties + sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud radiative properties + sw_optical_props_cnvclouds, & ! RRTMGP DDT: shortwave convecive cloud radiative properties + sw_optical_props_precip, & ! RRTMGP DDT: shortwave precipitation radiative properties + sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol radiative properties real(kind_phys), dimension(sw_gas_props%get_nband(),ncol), intent(in) :: & - sfc_alb_nir_dir, & ! Surface albedo (direct) - sfc_alb_nir_dif, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir, & ! Surface albedo (direct) - sfc_alb_uvvis_dif ! Surface albedo (diffuse) + sfc_alb_nir_dir, & ! Surface albedo (direct) + sfc_alb_nir_dif, & ! Surface albedo (diffuse) + sfc_alb_uvvis_dir, & ! Surface albedo (direct) + sfc_alb_uvvis_dif ! Surface albedo (diffuse) real(kind_phys), dimension(ncol,sw_gas_props%get_ngpt()), intent(in) :: & - toa_src_sw ! TOA incident spectral flux (W/m2) + toa_src_sw ! TOA incident spectral flux (W/m2) ! Outputs character(len=*), intent(out) :: & @@ -121,7 +125,10 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz endif enddo + ! ! Compute clear-sky fluxes (if requested) + ! + ! Clear-sky fluxes (gas+aerosol) call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_aerosol%increment(sw_optical_props_clrsky)) ! Delta-scale optical properties @@ -139,10 +146,20 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz fluxswUP_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_up,dim=3) fluxswDOWN_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_dn,dim=3) endif - + + ! ! Compute all-sky fluxes - ! All-sky fluxes (clear-sky + clouds) + ! + + ! Include convective cloud? + if (doGP_convcld) then + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_cnvclouds%increment(sw_optical_props_clrsky)) + endif + + ! All-sky fluxes (clear-sky + clouds + precipitation) + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_precip%increment(sw_optical_props_clrsky)) call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clouds%increment(sw_optical_props_clrsky)) + ! Delta-scale optical properties call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) call check_error_msg('rrtmgp_sw_rte_run',rte_sw( & diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index e59698c0f..bf1b43179 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -22,6 +22,13 @@ dimensions = () type = logical intent = in +[doGP_convcld] + standard_name = flag_to_include_convective_cloud_in_RRTMGP + long_name = logical flag to control convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -102,6 +109,20 @@ dimensions = () type = ty_optical_props_2str intent = in +[sw_optical_props_precip] + standard_name = shortwave_optical_properties_for_precipitation + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[sw_optical_props_cnvclouds] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in [sw_optical_props_aerosol] standard_name = shortwave_optical_properties_for_aerosols long_name = Fortran DDT containing RRTMGP optical properties From dcbad0ae347645feb1e063daba429bde95498fdc Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 25 Feb 2022 23:44:31 +0000 Subject: [PATCH 076/217] Some cleanup and bug fixes from previous commit. working now with Thompson MP plus radiatively active convective cloud. --- physics/GFS_rrtmgp_cloud_mp.F90 | 31 +++++++++++++++++++-------- physics/GFS_rrtmgp_cloud_mp.meta | 10 ++++----- physics/GFS_rrtmgp_cloud_overlap.meta | 4 ++-- physics/rrtmgp_lw_cloud_sampling.F90 | 9 ++++---- physics/rrtmgp_lw_cloud_sampling.meta | 11 ++-------- physics/rrtmgp_sw_cloud_sampling.F90 | 2 +- physics/rrtmgp_sw_cloud_sampling.meta | 4 ++-- 7 files changed, 38 insertions(+), 33 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 601c2ed0a..af94f2ee0 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -102,7 +102,6 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic relhum, & ! Relative humidity p_lay, & ! Pressure at model-layers (Pa) cnv_mixratio, & ! Convective cloud mixing-ratio (kg/kg) - cnv_cldfrac, & ! Convective cloud-fraction (1) qci_conv ! real(kind_phys), dimension(:,:), intent(inout) :: & effrin_cldliq, & ! Effective radius for stratiform liquid cloud-particles (microns) @@ -132,6 +131,7 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic cld_rwp, & ! Cloud rain water path cld_rerain, & ! Cloud rain effective radius precip_frac, & ! Precipitation fraction + cnv_cldfrac, & ! Convective cloud-fraction (1) cnv_cld_lwp, & ! Water path for convective liquid cloud-particles (microns) cnv_cld_reliq, & ! Effective radius for convective liquid cloud-particles (microns) cnv_cld_iwp, & ! Water path for convective ice cloud-particles (microns) @@ -214,9 +214,9 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic else ! if (doGP_convcld) then - call cloud_mp_convective(nCol, nLev, t_lay, p_lev, cnv_mixratio, & - cnv_cldfrac, con_ttp, con_g, cnv_cld_lwp, cnv_cld_reliq, & - cnv_cld_iwp, cnv_cld_reice) + call cloud_mp_convective(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, & + relhum, cnv_mixratio, con_ttp, con_g, cnv_cld_lwp, cnv_cld_reliq, & + cnv_cld_iwp, cnv_cld_reice, cnv_cldfrac) endif ! call cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & @@ -250,8 +250,9 @@ end subroutine GFS_rrtmgp_cloud_mp_finalize ! ###################################################################################### ! ###################################################################################### - subroutine cloud_mp_convective(nCol, nLev, t_lay, p_lev, cnv_mixratio, cnv_cldfrac, & - con_ttp, con_g, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice) + subroutine cloud_mp_convective(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, & + cnv_mixratio, con_ttp, con_g, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, & + cnv_cld_reice, cnv_cldfrac) ! Inputs integer, intent(in) :: & nCol, & ! Number of horizontal grid points @@ -262,17 +263,29 @@ subroutine cloud_mp_convective(nCol, nLev, t_lay, p_lev, cnv_mixratio, cnv_cldfr real(kind_phys), dimension(:,:),intent(in) :: & t_lay, & ! Temperature at layer centers (K) p_lev, & ! Pressure at layer interfaces (Pa) - cnv_mixratio, & ! Convective cloud mixing-ratio (kg/kg) - cnv_cldfrac ! Convective cloud-fraction (1) + p_lay, & ! + qs_lay, & ! + relhum, & ! + cnv_mixratio ! Convective cloud mixing-ratio (kg/kg) ! Outputs real(kind_phys), dimension(:,:),intent(inout) :: & cnv_cld_lwp, & ! Convective cloud liquid water path cnv_cld_reliq, & ! Convective cloud liquid effective radius cnv_cld_iwp, & ! Convective cloud ice water path - cnv_cld_reice ! Convective cloud ice effecive radius + cnv_cld_reice, & ! Convective cloud ice effecive radius + cnv_cldfrac ! Convective cloud-fraction (1) ! Local integer :: iCol, iLay real(kind_phys) :: tem1, deltaP, clwc + real(kind_phys), parameter :: alpha0=200 + + ! Xu-Randall (1996) cloud-fraction. + do iLay = 1, nLev + do iCol = 1, nCol + cnv_cldfrac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & + qs_lay(iCol,iLay), relhum(iCol,iLay), cnv_mixratio(iCol,iLay), alpha0) + enddo + enddo do iLay = 1, nLev do iCol = 1, nCol diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index d2eb9c40c..d5db1c5ff 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -357,21 +357,21 @@ kind = kind_phys intent = in [cnv_mixratio] - standard_name = convective_cloud_condensate_mixing_ratio - long_name = convective cloud water mixing ratio in the phy_f3d array + standard_name = convective_cloud_water_mixing_ratio + long_name = moist convective cloud water mixing ratio units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in [cnv_cldfrac] - standard_name = convective_cloud_area_fraction - long_name = convective cloud cover in the phy_f3d array + standard_name = convective_cloud_fraction_for_RRTMGP + long_name = layer convective cloud fraction units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = in + intent = inout [qci_conv] standard_name = convective_cloud_condesate_after_rainout long_name = convective cloud condesate after rainout diff --git a/physics/GFS_rrtmgp_cloud_overlap.meta b/physics/GFS_rrtmgp_cloud_overlap.meta index 1ab6c7ff3..abd83b2ab 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.meta +++ b/physics/GFS_rrtmgp_cloud_overlap.meta @@ -194,8 +194,8 @@ kind = kind_phys intent = in [cnv_cldfrac] - standard_name = convective_cloud_area_fraction - long_name = convective cloud cover in the phy_f3d array + standard_name = convective_cloud_fraction_for_RRTMGP + long_name = layer convective cloud fraction units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 index 8f4b79b61..131cfd168 100644 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ b/physics/rrtmgp_lw_cloud_sampling.F90 @@ -21,7 +21,7 @@ module rrtmgp_lw_cloud_sampling subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iovr_convcld,& iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, & cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, cnv_cldfrac, & - cnv_cloud_overlap_param, doGP_lwscat, doGP_convcld, lw_optical_props_cloudsByBand, & + cnv_cloud_overlap_param, doGP_convcld, lw_optical_props_cloudsByBand, & lw_optical_props_cnvcloudsByBand, lw_optical_props_precipByBand, & lw_optical_props_clouds, lw_optical_props_cnvclouds, lw_optical_props_precip, & errmsg, errflg) @@ -29,7 +29,6 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iov ! Inputs logical, intent(in) :: & doLWrad, & ! Logical flag for shortwave radiation call - doGP_lwscat, & ! Include scattering in LW cloud-optics? doGP_convcld integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints @@ -151,7 +150,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iov ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_lw_cloud_sampling_run_draw_samples',& - draw_samples(maskMCICA, doGP_lwscat, & + draw_samples(maskMCICA, .true., & lw_optical_props_cloudsByBand, & lw_optical_props_clouds)) @@ -188,7 +187,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iov ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_lw_cnvcloud_sampling_run_draw_samples',& - draw_samples(maskMCICA, doGP_lwscat, & + draw_samples(maskMCICA, .true., & lw_optical_props_cnvcloudsByBand, & lw_optical_props_cnvclouds)) endif @@ -224,7 +223,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iov ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_lw_precip_sampling_run_draw_samples',& - draw_samples(maskMCICA, doGP_lwscat, & + draw_samples(maskMCICA, .true., & lw_optical_props_precipByBand, & lw_optical_props_precip)) diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta index b68a85b0a..c2224cd78 100644 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ b/physics/rrtmgp_lw_cloud_sampling.meta @@ -14,13 +14,6 @@ dimensions = () type = logical intent = in -[doGP_lwscat] - standard_name = flag_to_include_longwave_scattering_in_cloud_optics - long_name = logical flag to control the addition of LW scattering in RRTMGP - units = flag - dimensions = () - type = logical - intent = in [doGP_convcld] standard_name = flag_to_include_convective_cloud_in_RRTMGP long_name = logical flag to control convective cloud in RRTMGP @@ -121,8 +114,8 @@ kind = kind_phys intent = in [cnv_cldfrac] - standard_name = convective_cloud_area_fraction - long_name = convective cloud cover in the phy_f3d array + standard_name = convective_cloud_fraction_for_RRTMGP + long_name = layer convective cloud fraction units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 index 6ad6058da..30a4cdf32 100644 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -164,7 +164,7 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, ! Allocate space RRTMGP DDTs [nday,nLev,nGpt] call check_error_msg('rrtmgp_sw_cnvcloud_sampling_run', & - sw_optical_props_precip%alloc_2str( nday, nLev, sw_gas_props)) + sw_optical_props_cnvclouds%alloc_2str( nday, nLev, sw_gas_props)) ! Maximum-random, random or maximum overlap if (iovr_convcld == iovr_maxrand .or. iovr_convcld == iovr_max .or. iovr_convcld == iovr_rand) then diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta index fb1edd10e..c5b3bce10 100644 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ b/physics/rrtmgp_sw_cloud_sampling.meta @@ -136,8 +136,8 @@ kind = kind_phys intent = in [cnv_cldfrac] - standard_name = convective_cloud_area_fraction - long_name = convective cloud cover in the phy_f3d array + standard_name = convective_cloud_fraction_for_RRTMGP + long_name = layer convective cloud fraction units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real From 44a2bd943fd4a23b7104dbba37bfb6f84e03425f Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 2 Mar 2022 22:06:55 -0700 Subject: [PATCH 077/217] Add logic to reduce optimization for multiple files, independent of their preceding paths --- CMakeLists.txt | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index f16014cb7..cfbbae966 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -42,6 +42,7 @@ else(TYPEDEFS) include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_TYPEDEFS.cmake) message(STATUS "Got CCPP TYPEDEFS from cmakefile include file") endif(TYPEDEFS) +list(REMOVE_DUPLICATES TYPEDEFS) # Generate list of Fortran modules from the CCPP type # definitions that need need to be installed @@ -58,6 +59,7 @@ else(SCHEMES) include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_SCHEMES.cmake) message(STATUS "Got CCPP SCHEMES from cmakefile include file") endif(SCHEMES) +list(REMOVE_DUPLICATES SCHEMES) # Set the sources: physics scheme caps set(CAPS $ENV{CCPP_CAPS}) @@ -67,6 +69,7 @@ else(CAPS) include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_CAPS.cmake) message(STATUS "Got CCPP CAPS from cmakefile include file") endif(CAPS) +list(REMOVE_DUPLICATES CAPS) # Schemes and caps from the CCPP code generator use full paths with symlinks # resolved, we need to do the same here for the below logic to work @@ -141,12 +144,19 @@ endif() SET_PROPERTY(SOURCE ${SCHEMES} ${CAPS} APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS}") -# Reduce optimization for module_sf_mynn.F90 (to avoid an apparent compiler bug with Intel 18 on Hera) -if(${LOCAL_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 IN_LIST SCHEMES AND - (CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND +# Lower optimization for certain schemes when compiling with Intel in Release mode +if((CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") - SET_SOURCE_FILES_PROPERTIES(${LOCAL_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 - APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS} -O1") + # Define a list of schemes that need lower optimization with Intel in Release mode + set(SCHEME_NAMES_LOWER_OPTIMIZATION GFS_typedefs.F90 + module_sf_mynn.F90) + foreach(SCHEME_NAME IN LISTS SCHEME_NAMES_LOWER_OPTIMIZATION) + set(SCHEMES_TMP ${SCHEMES}) + # Need to determine the name of the scheme with its path + list(FILTER SCHEMES_TMP INCLUDE REGEX ".*${SCHEME_NAME}$") + SET_SOURCE_FILES_PROPERTIES(${SCHEMES_TMP} + APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS} -O1") + endforeach() endif() # Reduce optimization for mo_gas_optics_kernels.F90 (to avoid an apparent compiler bug with Intel 19+) From 4d808f85fb91952e4f1ed1bb9ce2cb4950457042 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 3 Mar 2022 07:08:44 -0700 Subject: [PATCH 078/217] No optimization for GFS_typedefs.F90 --- CMakeLists.txt | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index cfbbae966..17ccabebc 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -148,8 +148,7 @@ SET_PROPERTY(SOURCE ${SCHEMES} ${CAPS} if((CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") # Define a list of schemes that need lower optimization with Intel in Release mode - set(SCHEME_NAMES_LOWER_OPTIMIZATION GFS_typedefs.F90 - module_sf_mynn.F90) + set(SCHEME_NAMES_LOWER_OPTIMIZATION module_sf_mynn.F90) foreach(SCHEME_NAME IN LISTS SCHEME_NAMES_LOWER_OPTIMIZATION) set(SCHEMES_TMP ${SCHEMES}) # Need to determine the name of the scheme with its path @@ -159,6 +158,20 @@ if((CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit" endforeach() endif() +# No optimization for certain schemes when compiling with Intel in Release mode +if((CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND + ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") + # Define a list of schemes that can't be optimized with Intel in Release mode + set(SCHEME_NAMES_NO_OPTIMIZATION GFS_typedefs.F90) + foreach(SCHEME_NAME IN LISTS SCHEME_NAMES_NO_OPTIMIZATION) + set(SCHEMES_TMP ${SCHEMES}) + # Need to determine the name of the scheme with its path + list(FILTER SCHEMES_TMP INCLUDE REGEX ".*${SCHEME_NAME}$") + SET_SOURCE_FILES_PROPERTIES(${SCHEMES_TMP} + APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS} -O0") + endforeach() +endif() + # Reduce optimization for mo_gas_optics_kernels.F90 (to avoid an apparent compiler bug with Intel 19+) if(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 IN_LIST SCHEMES_OPENMP_OFF AND (CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND From 5830a822acb61ff9a51980f209594527377a9e41 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 3 Mar 2022 18:09:31 +0000 Subject: [PATCH 079/217] RRTMGP coupling to Thompson MP (Sundqvist 1989) --- physics/GFS_rrtmgp_cloud_mp.F90 | 35 ++++++++++++--- physics/GFS_rrtmgp_cloud_mp.meta | 50 ++++++++++++++++++++- physics/GFS_rrtmgp_cloud_overlap.F90 | 28 ++---------- physics/GFS_rrtmgp_cloud_overlap.meta | 16 +++---- physics/GFS_rrtmgp_pre.F90 | 65 +++++++++++++++++++++++++-- physics/GFS_rrtmgp_pre.meta | 40 +++++++++++++++++ 6 files changed, 190 insertions(+), 44 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index af94f2ee0..a5bcfdf7d 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -1,8 +1,9 @@ -! ###########update_############################################################################# +! ######################################################################################## ! ######################################################################################## module GFS_rrtmgp_cloud_mp use machine, only: kind_phys use radiation_tools, only: check_error_msg + use module_radiation_clouds, only: progcld_thompson use rrtmgp_lw_cloud_optics, only: & radliq_lwr => radliq_lwrLW, radliq_upr => radliq_uprLW,& radice_lwr => radice_lwrLW, radice_upr => radice_uprLW @@ -40,8 +41,9 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic imp_physics, imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, lgfdlmprad, & imp_physics_fer_hires, do_mynnedmf, uni_cld, lmfdeep2, doGP_convcld, p_lev, & - p_lay, t_lay, qs_lay, q_lay, relhum, lsmask, tv_lay, effrin_cldliq, effrin_cldice,& - effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cnv_cldfrac, qci_conv, & + p_lay, t_lay, qs_lay, q_lay, relhum, lsmask, xlon, xlat, dx, tv_lay, & + effrin_cldliq, effrin_cldice, effrin_cldrain, effrin_cldsnow, tracer, & + cnv_mixratio, cnv_cldfrac, qci_conv, deltaZ, deltaZc, deltaP, & con_g, con_rd, con_eps, con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & cld_rerain, precip_frac, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice, & @@ -93,7 +95,10 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic con_ttp, & ! Triple point temperature of water (K) con_eps ! Physical constant: gas constant air / gas constant H2O real(kind_phys), dimension(:), intent(in) :: & - lsmask ! Land/Sea mask + lsmask, & ! Land/Sea mask + xlon, & ! Longitude + xlat, & ! Latitude + dx ! real(kind_phys), dimension(:,:), intent(in) :: & tv_lay, & ! Virtual temperature (K) t_lay, & ! Temperature (K) @@ -102,7 +107,10 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic relhum, & ! Relative humidity p_lay, & ! Pressure at model-layers (Pa) cnv_mixratio, & ! Convective cloud mixing-ratio (kg/kg) - qci_conv ! + qci_conv, & ! + deltaZ, & ! + deltaZc, & ! + deltaP ! real(kind_phys), dimension(:,:), intent(inout) :: & effrin_cldliq, & ! Effective radius for stratiform liquid cloud-particles (microns) effrin_cldice, & ! Effective radius for stratiform ice cloud-particles (microns) @@ -143,6 +151,7 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic ! Local integer :: iCol, iLay + real (kind=kind_phys), dimension(nCol,nLev) :: cldcov, cldtot, cldcnv if (.not. (doSWrad .or. doLWrad)) return @@ -200,7 +209,21 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then if (icloud == 3) then ! Call progcld_thompson + call progcld_thompson(p_lay, p_lev, t_lay, q_lay, qs_lay, relhum, tracer, & + xlat, xlon, lsmask, deltaZ*0.001, deltaP, ncnd, i_cldliq, i_cldice, & + i_cldrain, i_cldsnow, i_cldgrpl, nCol, nLev, nLev+1, uni_cld, lmfshal,& + lmfdeep2, & + cldcov, & ! This is an input, but not used... + effrin_cldliq, effrin_cldice, effrin_cldsnow, lwp_ex, iwp_ex, lwp_fc, & + iwp_fc, deltaZc*0.001, dx*0.001, & + cldtot, cldcnv, & ! These are local variables, no intent given.... + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_rwp, cld_rerain,& + cld_swp, cld_resnow) + else + ! MYNN PBL or convective GF. Use cloud fractions with SGS clouds. + ! cld_frac, cld_lwp, and cld_iwp, are modified prior to include subgrid- + ! scale cloudiness, in module_SGSCloud_RadPre.F90. call cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, & p_lev, p_lay, t_lay, tv_lay, effrin_cldliq, effrin_cldice, & @@ -399,7 +422,7 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai ! Particle size do iLay = 1, nLev do iCol = 1, nCol - ! Use radii provided from the macrophysics + ! Use radii provided from the macrophysics if (effr_in) then cld_reliq(iCol,iLay) = effrin_cldliq(iCol,iLay) cld_reice(iCol,iLay) = max(reice_min, min(reice_max,effrin_cldice(iCol,iLay))) diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index d5db1c5ff..10d6d1c12 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rrtmgp_cloud_mp type = scheme - dependencies = radiation_tools.F90, radiation_cloud_overlap.F90, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90, rrtmgp_lw_cloud_optics.F90 + dependencies = radiation_tools.F90, radiation_clouds.f, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90, rrtmgp_lw_cloud_optics.F90 ######################################################################## [ccpp-arg-table] @@ -260,6 +260,30 @@ type = real kind = kind_phys intent = in +[xlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dx] + standard_name = characteristic_grid_lengthscale + long_name = relative dx for the grid cell + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [p_lev] standard_name = air_pressure_at_interface_for_RRTMGP long_name = air pressure at vertical interface for radiation calculation @@ -380,6 +404,30 @@ type = real kind = kind_phys intent = in +[deltaZ] + standard_name = layer_thickness + long_name = layer_thickness + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[deltaZc] + standard_name = layer_thickness_from_layer_center + long_name = layer_thickness + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[deltaP] + standard_name = layer_thickness_in_Pa + long_name = layer_thickness_in_Pa + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 index 0a20b7a94..3a30d2f32 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -4,7 +4,7 @@ module GFS_rrtmgp_cloud_overlap use machine, only: kind_phys use radiation_tools, only: check_error_msg - use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exp + use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exper public GFS_rrtmgp_cloud_overlap_init, GFS_rrtmgp_cloud_overlap_run, GFS_rrtmgp_cloud_overlap_finalize @@ -102,44 +102,22 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! Cloud overlap parameter ! if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then - call get_alpha_exp(nCol, nLev, deltaZc*0.001, de_lgth, cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001, de_lgth, cld_frac, cloud_overlap_param) else de_lgth(:) = 0. cloud_overlap_param(:,:) = 0. endif - ! For exponential random overlap... - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == iovr_exprand) then - do iLay = 1, nLev - do iCol = 1, nCol - if (cld_frac(iCol,iLay) .eq. 0. .and. cld_frac(iCol,iLay-1) .gt. 0.) then - cloud_overlap_param(iCol,iLay) = 0._kind_phys - endif - enddo - enddo - endif - ! ! Convective cloud overlap parameter ! if (doGP_convcld) then if (iovr_convcld == iovr_dcorr .or. iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then - call get_alpha_exp(nCol, nLev, deltaZc*0.001, de_lgth, cnv_cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001, de_lgth, cnv_cldfrac, cnv_cloud_overlap_param) else de_lgth(:) = 0. cnv_cloud_overlap_param(:,:) = 0. endif - if (iovr_convcld == iovr_exprand) then - do iLay = 1, nLev - do iCol = 1, nCol - if (cnv_cldfrac(iCol,iLay) .eq. 0. .and. cnv_cldfrac(iCol,iLay-1) .gt. 0.) then - cnv_cloud_overlap_param(iCol,iLay) = 0._kind_phys - endif - enddo - enddo - endif endif ! diff --git a/physics/GFS_rrtmgp_cloud_overlap.meta b/physics/GFS_rrtmgp_cloud_overlap.meta index abd83b2ab..eb16f9159 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.meta +++ b/physics/GFS_rrtmgp_cloud_overlap.meta @@ -82,6 +82,14 @@ type = real kind = kind_phys intent = in +[deltaZc] + standard_name = layer_thickness_from_layer_center + long_name = layer_thickness + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [con_pi] standard_name = pi long_name = ratio of a circle's circumference to its diameter @@ -247,14 +255,6 @@ type = real kind = kind_phys intent = out -[deltaZc] - standard_name = layer_thickness - long_name = layer_thickness - units = m - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index d3620a5fd..d222ac498 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -99,9 +99,9 @@ end subroutine GFS_rrtmgp_pre_init !! \htmlinclude GFS_rrtmgp_pre_run.html !! subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, fhlwr, & - xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, coslat, sinlat, con_eps, con_epsm1,& + xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, coslat, sinlat, con_g, con_rd, con_eps, con_epsm1,& con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, maxGPtemp, raddt, & - p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, tracer, & + p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, tracer, deltaZ, deltaZc, deltaP, & active_gases_array, gas_concentrations, tsfc_radtime, coszen, coszdg, top_at_1, iSFC,& iTOA, errmsg, errflg) @@ -122,6 +122,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw fhswr, & ! Frequency of SW radiation call. fhlwr ! Frequency of LW radiation call. real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_rd, & ! Physical constant: gas-constant for dry air con_eps, & ! Physical constant: Epsilon (Rd/Rv) con_epsm1, & ! Physical constant: Epsilon (Rd/Rv) minus one con_fvirt, & ! Physical constant: Inverse of epsilon minus one @@ -163,7 +165,10 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw q_lay, & ! Water-vapor mixing ratio (kg/kg) tv_lay, & ! Virtual temperature at model-layers relhum, & ! Relative-humidity at model-layers - qs_lay ! Saturation vapor pressure at model-layers + qs_lay, & ! Saturation vapor pressure at model-layers + deltaZ, & ! Layer thickness (m) + deltaZc, & ! Layer thickness (m) (between layer centers) + deltaP ! Layer thickness (Pa) real(kind_phys), dimension(nCol,nLev+1), intent(inout) :: & p_lev, & ! Pressure at model-interface t_lev ! Temperature at model-interface @@ -180,7 +185,9 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! Local variables integer :: i, j, iCol, iBand, iLay real(kind_phys),dimension(nCol,nLev) :: vmr_o3, vmr_h2o - real(kind_phys) :: es, tem1, tem2 + real(kind_phys) :: es, tem1, tem2, pfac + real(kind_phys), dimension(nLev+1) :: hgtb + real(kind_phys), dimension(nLev) :: hgtc real(kind_phys), dimension(nCol,nLev) :: o3_lay real(kind_phys), dimension(nCol,nLev, NF_VGAS) :: gas_vmr @@ -256,6 +263,56 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw enddo enddo + ! + ! Compute layer-thickness between layer boundaries (deltaZ) and layer centers (deltaZc) + ! + deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev)) + do iCol=1,nCol + if (top_at_1) then + ! Layer thickness (m) + do iLay=1,nLev + deltaZ(iCol,iLay) = ((con_rd/con_g)) * abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) * tv_lay(iCol,iLay) + enddo + ! Height at layer boundaries + hgtb(nLev+1) = 0._kind_phys + do iLay=nLev,1,-1 + hgtb(iLay)= hgtb(iLay+1) + deltaZ(iCol,iLay) + enddo + ! Height at layer centers + do iLay = nLev, 1, -1 + pfac = abs(log(p_lev(iCol,iLay+1)) - log(p_lay(iCol,iLay))) / & + abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) + hgtc(iLay) = hgtb(iLay+1) + pfac * (hgtb(iLay) - hgtb(iLay+1)) + enddo + ! Layer thickness between centers + do iLay = nLev-1, 1, -1 + deltaZc(iCol,iLay) = hgtc(iLay) - hgtc(iLay+1) + enddo + deltaZc(iCol,nLev) = hgtc(nLev) - hgtb(nLev+1) + else + ! Layer thickness (m) + do iLay=nLev,1,-1 + deltaZ(iCol,iLay) = ((con_rd/con_g)) * abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) * tv_lay(iCol,iLay) + enddo + ! Height at layer boundaries + hgtb(1) = 0._kind_phys + do iLay=1,nLev + hgtb(iLay+1)= hgtb(iLay) + deltaZ(iCol,iLay) + enddo + ! Height at layer centers + do iLay = 1, nLev + pfac = abs(log(p_lev(iCol,iLay)) - log(p_lay(iCol,iLay) )) / & + abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) + hgtc(iLay) = hgtb(iLay) + pfac * (hgtb(iLay+1) - hgtb(iLay)) + enddo + ! Layer thickness between centers + do iLay = 2, nLev + deltaZc(iCol,iLay) = hgtc(iLay) - hgtc(iLay-1) + enddo + deltaZc(iCol,1) = hgtc(1) - hgtb(1) + endif + enddo + ! ####################################################################################### ! Get layer ozone mass mixing ratio ! ####################################################################################### diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 501dacfa1..7fa29ea8c 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -204,6 +204,22 @@ type = real kind = kind_phys intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in [con_eps] standard_name = ratio_of_dry_air_to_water_vapor_gas_constants long_name = rd/rv @@ -308,6 +324,30 @@ type = real kind = kind_phys intent = inout +[deltaZ] + standard_name = layer_thickness + long_name = layer_thickness + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[deltaZc] + standard_name = layer_thickness_from_layer_center + long_name = layer_thickness + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[deltaP] + standard_name = layer_thickness_in_Pa + long_name = layer_thickness_in_Pa + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [top_at_1] standard_name = flag_for_vertical_ordering_in_RRTMGP long_name = flag for vertical ordering in RRTMGP From 6467693b63c3110fedb7c8f8fc32d0d07613b72b Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 3 Mar 2022 12:02:19 -0700 Subject: [PATCH 080/217] update scm_sfc_flux_spec scheme to set some variables needed by non-surface physics --- physics/scm_sfc_flux_spec.F90 | 98 +++++++++++++++++-- physics/scm_sfc_flux_spec.meta | 166 +++++++++++++++++++++++++++++++++ 2 files changed, 257 insertions(+), 7 deletions(-) diff --git a/physics/scm_sfc_flux_spec.F90 b/physics/scm_sfc_flux_spec.F90 index e4f425eb2..a19f9abbb 100644 --- a/physics/scm_sfc_flux_spec.F90 +++ b/physics/scm_sfc_flux_spec.F90 @@ -52,18 +52,25 @@ end subroutine scm_sfc_flux_spec_finalize !! -# Calculate the Monin-Obukhov similarity function for heat and moisture from the bulk Richardson number and diagnosed similarity function for momentum. !! -# Calculate the surface drag coefficient for heat and moisture. !! -# Calculate the u and v wind at 10m. - subroutine scm_sfc_flux_spec_run (u1, v1, z1, t1, q1, p1, roughness_length, spec_sh_flux, spec_lh_flux, & - exner_inverse, T_surf, cp, grav, hvap, rd, fvirt, vonKarman, sh_flux, lh_flux, sh_flux_chs, u_star, sfc_stress, cm, ch, & + subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, spec_sh_flux, spec_lh_flux, & + exner_inverse, T_surf, cp, grav, hvap, rd, fvirt, vonKarman, tgice, islmsk, dry, frland, cice, icy, tisfc,& + oceanfrac, min_seaice, cplflx, cplice, flag_cice, wet, min_lakeice, tsfcl, tsfc_wat, slmsk, lakefrac, lkm,& + lakedepth, use_flake, sh_flux, lh_flux, sh_flux_chs, u_star, sfc_stress, cm, ch, & fm, fh, rb, u10m, v10m, wind1, qss, t2m, q2m, errmsg, errflg) use machine, only: kind_phys + integer, intent(in) :: im, lkm + integer, intent(inout) :: islmsk(:) + logical, intent(in) :: cplflx, cplice + logical, intent(inout) :: dry(:), icy(:), flag_cice(:), wet(:), use_flake(:) real(kind=kind_phys), intent(in) :: u1(:), v1(:), z1(:), t1(:), q1(:), p1(:), roughness_length(:), & - spec_sh_flux(:), spec_lh_flux(:), exner_inverse(:), T_surf(:) - real(kind=kind_phys), intent(in) :: cp, grav, hvap, rd, fvirt, vonKarman + spec_sh_flux(:), spec_lh_flux(:), exner_inverse(:), T_surf(:), oceanfrac(:), lakefrac(:), lakedepth(:) + real(kind=kind_phys), intent(in) :: cp, grav, hvap, rd, fvirt, vonKarman, min_seaice, tgice, min_lakeice + real(kind=kind_phys), intent(inout) :: cice(:), tisfc(:), tsfcl(:), tsfc_wat(:), slmsk(:) real(kind=kind_phys), intent(out) :: sh_flux(:), lh_flux(:), u_star(:), sfc_stress(:), & cm(:), ch(:), fm(:), fh(:), rb(:), u10m(:), v10m(:), wind1(:), qss(:), t2m(:), q2m(:), & - sh_flux_chs(:) + sh_flux_chs(:), frland(:) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -72,6 +79,8 @@ subroutine scm_sfc_flux_spec_run (u1, v1, z1, t1, q1, p1, roughness_length, spec real(kind=kind_phys) :: rho, q1_non_neg, w_thv1, rho_cp_inverse, rho_hvap_inverse, Obukhov_length, thv1, tvs, & dtv, adtv, wind10m, u_fraction, roughness_length_m + + real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice ! Initialize CCPP error handling variables errmsg = '' @@ -79,7 +88,7 @@ subroutine scm_sfc_flux_spec_run (u1, v1, z1, t1, q1, p1, roughness_length, spec ! !--- set control properties (including namelist read) !calculate u_star from wind profiles (need roughness length, and wind and height at lowest model level) - do i=1, size(z1) + do i=1, im sh_flux(i) = spec_sh_flux(i) lh_flux(i) = spec_lh_flux(i) sh_flux_chs(i) = sh_flux(i) @@ -135,7 +144,82 @@ subroutine scm_sfc_flux_spec_run (u1, v1, z1, t1, q1, p1, roughness_length, spec t2m(i) = 0.0 q2m(i) = 0.0 end do - + + !GJF: The following code is from GFS_surface_composites.F90; only statements that are used in physics schemes outside of surface schemes are kept + !GJF: Adding this code means that this scheme should be called before dcyc2t3 + do i = 1, im + if (islmsk(i) == 1) then + dry(i) = .true. + frland(i) = 1.0_kind_phys + cice(i) = 0.0_kind_phys + icy(i) = .false. + tsfcl(i) = T_surf(i) !GJF + else + frland(i) = 0.0_kind_phys + if (oceanfrac(i) > 0.0_kind_phys) then + if (cice(i) >= min_seaice) then + icy(i) = .true. + tisfc(i) = T_surf(i) !GJF + tisfc(i) = max(timin, min(tisfc(i), tgice)) + ! This cplice namelist option was added to deal with the + ! situation of the FV3ATM-HYCOM coupling without an active sea + ! ice (e.g., CICE6) component. By default, the cplice is true + ! when cplflx is .true. (e.g., for the S2S application). + ! Whereas, for the HAFS FV3ATM-HYCOM coupling, cplice is set as + ! .false.. In the future HAFS FV3ATM-MOM6 coupling, the cplflx + ! could be .true., while cplice being .false.. + if (cplice .and. cplflx) then + flag_cice(i) = .true. + else + flag_cice(i) = .false. + endif + islmsk(i) = 2 + else + cice(i) = 0.0_kind_phys + flag_cice(i) = .false. + islmsk(i) = 0 + icy(i) = .false. + endif + if (cice(i) < 1.0_kind_phys) then + wet(i) = .true. ! some open ocean + endif + else + if (cice(i) >= min_lakeice) then + icy(i) = .true. + tisfc(i) = T_surf(i) !GJF + tisfc(i) = max(timin, min(tisfc(i), tgice)) + islmsk(i) = 2 + else + cice(i) = 0.0_kind_phys + islmsk(i) = 0 + icy(i) = .false. + endif + flag_cice(i) = .false. + if (cice(i) < 1.0_kind_phys) then + wet(i) = .true. ! some open lake + endif + if (wet(i)) then ! Water + tsfc_wat(i) = T_surf(i) + endif + endif + endif + if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) + enddo + +! to prepare to separate lake from ocean under water category + do i = 1, im + if ((wet(i) .or. icy(i)) .and. lakefrac(i) > 0.0_kind_phys) then + if (lkm == 1 .and. lakefrac(i) >= 0.15 .and. lakedepth(i) > 1.0_kind_phys) then + use_flake(i) = .true. + else + use_flake(i) = .false. + endif + else + use_flake(i) = .false. + endif + enddo +! + end subroutine scm_sfc_flux_spec_run end module scm_sfc_flux_spec diff --git a/physics/scm_sfc_flux_spec.meta b/physics/scm_sfc_flux_spec.meta index 46bb10897..03e3205f5 100644 --- a/physics/scm_sfc_flux_spec.meta +++ b/physics/scm_sfc_flux_spec.meta @@ -34,6 +34,13 @@ [ccpp-arg-table] name = scm_sfc_flux_spec_run type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in [u1] standard_name = x_wind_at_surface_adjacent_layer long_name = x component of 1st model layer wind @@ -170,6 +177,165 @@ type = real kind = kind_phys intent = in +[tgice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[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 = inout +[frland] + standard_name = land_area_fraction_for_microphysics + long_name = land area fraction used in microphysics schemes + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[cice] + standard_name = sea_ice_area_fraction_of_sea_area_fraction + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[tisfc] + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[min_seaice] + standard_name = min_sea_ice_area_fraction + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[cplflx] + standard_name = flag_for_surface_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[cplice] + standard_name = flag_for_sea_ice_coupling + long_name = flag controlling cplice collection (default on) + units = flag + dimensions = () + type = logical + intent = in +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[min_lakeice] + standard_name = min_lake_ice_area_fraction + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[tsfcl] + standard_name = surface_skin_temperature_over_land + long_name = surface skin temperature over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfc_wat] + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[slmsk] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lkm] + standard_name = control_for_lake_surface_scheme + long_name = flag for lake surface model + units = flag + dimensions = () + type = integer + intent = in +[lakedepth] + standard_name = lake_depth + long_name = lake depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout [sh_flux] standard_name = surface_upward_temperature_flux long_name = surface upward sensible heat flux From bcbea3250beab60544cd838880061da985be6b0f Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 3 Mar 2022 20:21:56 +0000 Subject: [PATCH 081/217] Housekeeping --- physics/GFS_rrtmgp_cloud_mp.F90 | 57 +++- physics/GFS_rrtmgp_gfdlmp_pre.F90 | 191 ------------- physics/GFS_rrtmgp_gfdlmp_pre.meta | 303 -------------------- physics/GFS_rrtmgp_thompsonmp_pre.F90 | 291 ------------------- physics/GFS_rrtmgp_thompsonmp_pre.meta | 377 ------------------------- physics/GFS_rrtmgp_zhaocarr_pre.F90 | 253 ----------------- physics/GFS_rrtmgp_zhaocarr_pre.meta | 366 ------------------------ 7 files changed, 44 insertions(+), 1794 deletions(-) delete mode 100644 physics/GFS_rrtmgp_gfdlmp_pre.F90 delete mode 100644 physics/GFS_rrtmgp_gfdlmp_pre.meta delete mode 100644 physics/GFS_rrtmgp_thompsonmp_pre.F90 delete mode 100644 physics/GFS_rrtmgp_thompsonmp_pre.meta delete mode 100644 physics/GFS_rrtmgp_zhaocarr_pre.F90 delete mode 100644 physics/GFS_rrtmgp_zhaocarr_pre.meta diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index a5bcfdf7d..b57e54d44 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -43,8 +43,8 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic imp_physics_fer_hires, do_mynnedmf, uni_cld, lmfdeep2, doGP_convcld, p_lev, & p_lay, t_lay, qs_lay, q_lay, relhum, lsmask, xlon, xlat, dx, tv_lay, & effrin_cldliq, effrin_cldice, effrin_cldrain, effrin_cldsnow, tracer, & - cnv_mixratio, cnv_cldfrac, qci_conv, deltaZ, deltaZc, deltaP, & - con_g, con_rd, con_eps, con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & + cnv_mixratio, cnv_cldfrac, qci_conv, deltaZ, deltaZc, deltaP, con_g, con_rd, & + con_eps, con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & cld_rerain, precip_frac, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice, & lwp_ex, iwp_ex, lwp_fc, iwp_fc, errmsg, errflg) @@ -98,7 +98,7 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic lsmask, & ! Land/Sea mask xlon, & ! Longitude xlat, & ! Latitude - dx ! + dx ! Characteristic grid lengthscale (m) real(kind_phys), dimension(:,:), intent(in) :: & tv_lay, & ! Virtual temperature (K) t_lay, & ! Temperature (K) @@ -107,10 +107,10 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic relhum, & ! Relative humidity p_lay, & ! Pressure at model-layers (Pa) cnv_mixratio, & ! Convective cloud mixing-ratio (kg/kg) - qci_conv, & ! - deltaZ, & ! - deltaZc, & ! - deltaP ! + qci_conv, & ! Convective cloud condesate after rainout (kg/kg) + deltaZ, & ! Layer-thickness (m) + deltaZc, & ! Layer-thickness, from layer centers (m) + deltaP ! Layer-thickness (Pa) real(kind_phys), dimension(:,:), intent(inout) :: & effrin_cldliq, & ! Effective radius for stratiform liquid cloud-particles (microns) effrin_cldice, & ! Effective radius for stratiform ice cloud-particles (microns) @@ -163,23 +163,38 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic ! GFDL Microphysics ! ################################################################################### if (imp_physics == imp_physics_gfdl) then + ! GFDL-Lin if (.not. lgfdlmprad) then - ! Call progcld_gfdl_lin + errflg = 1 + errmsg = "ERROR: MP choice not available with RRTMGP" + return + ! GFDL-EMC else - ! The cloud-fraction used for the radiation is conditional on other mp choices. + ! "cld_frac" is modified prior to include subgrid scale cloudiness, see + ! module_SGSCloud_RadPre.F90. do iLay = 1, nLev do iCol = 1, nCol + ! + ! SGS clouds present, use cloud-fraction modified to include sgs clouds. + ! if ((imfdeepcnv==imfdeepcnv_gf .or. do_mynnedmf) .and. kdt>1) then + ! MYNN sub-grid cloud fraction. if (do_mynnedmf) then + ! If rain/snow present, use GFDL MP cloud-fraction... if (tracer(iCol,iLay,i_cldrain)>1.0e-7 .OR. tracer(iCol,iLay,i_cldsnow)>1.0e-7) then cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) endif + ! GF sub-grid cloud fraction. else + ! If no convective cloud condensate present, use GFDL MP cloud-fraction.... if (qci_conv(iCol,iLay) <= 0.) then cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) endif endif + ! + ! No SGS clouds, use GFDL MP cloud-fraction... + ! else cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) endif @@ -206,9 +221,13 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic cld_reice = effrin_cldice cld_resnow = effrin_cldsnow + ! + ! SGS clouds present, use cloud-fraction modified to include sgs clouds. + ! if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then if (icloud == 3) then ! Call progcld_thompson + ! *NOTE* This routine is under active development call progcld_thompson(p_lay, p_lev, t_lay, q_lay, qs_lay, relhum, tracer, & xlat, xlon, lsmask, deltaZ*0.001, deltaP, ncnd, i_cldliq, i_cldice, & i_cldrain, i_cldsnow, i_cldgrpl, nCol, nLev, nLev+1, uni_cld, lmfshal,& @@ -221,9 +240,7 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic cld_swp, cld_resnow) else - ! MYNN PBL or convective GF. Use cloud fractions with SGS clouds. - ! cld_frac, cld_lwp, and cld_iwp, are modified prior to include subgrid- - ! scale cloudiness, in module_SGSCloud_RadPre.F90. + ! MYNN PBL or convective GF. call cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, & p_lev, p_lay, t_lay, tv_lay, effrin_cldliq, effrin_cldice, & @@ -231,11 +248,25 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & cld_rerain) endif + ! + ! No SGS clouds + ! else if (icloud == 3) then ! Call progcld_thompson + ! *NOTE* This routine is under active development + call progcld_thompson(p_lay, p_lev, t_lay, q_lay, qs_lay, relhum, tracer, & + xlat, xlon, lsmask, deltaZ*0.001, deltaP, ncnd, i_cldliq, i_cldice, & + i_cldrain, i_cldsnow, i_cldgrpl, nCol, nLev, nLev+1, uni_cld, lmfshal,& + lmfdeep2, & + cldcov, & ! This is an input, but not used... + effrin_cldliq, effrin_cldice, effrin_cldsnow, lwp_ex, iwp_ex, lwp_fc, & + iwp_fc, deltaZc*0.001, dx*0.001, & + cldtot, cldcnv, & ! These are local variables, no intent given... + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_rwp, cld_rerain,& + cld_swp, cld_resnow) else - ! + ! if (doGP_convcld) then call cloud_mp_convective(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, & relhum, cnv_mixratio, con_ttp, con_g, cnv_cld_lwp, cnv_cld_reliq, & diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 deleted file mode 100644 index 664da7528..000000000 --- a/physics/GFS_rrtmgp_gfdlmp_pre.F90 +++ /dev/null @@ -1,191 +0,0 @@ -! ######################################################################################## -! This module contains the interface between the GFDL macrophysics and the RRTMGP radiation -! schemes. Only compatable with Model%imp_physics = Model%imp_physics_gfdl -! ######################################################################################## -module GFS_rrtmgp_gfdlmp_pre - use machine, only: kind_phys - use radiation_tools, only: check_error_msg - use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exper - use rrtmgp_lw_cloud_optics, only: radliq_lwr => radliq_lwrLW, radliq_upr => radliq_uprLW,& - radice_lwr => radice_lwrLW, radice_upr => radice_uprLW - - ! Parameters - real(kind_phys), parameter :: & - reliq_def = 10.0 , & ! Default liq radius to 10 micron (used when effr_in=F) - reice_def = 50.0, & ! Default ice radius to 50 micron (used when effr_in=F) - rerain_def = 1000.0, & ! Default rain radius to 1000 micron (used when effr_in=F) - resnow_def = 250.0, & ! Default snow radius to 250 micron (used when effr_in=F) - reice_min = 10.0, & ! Minimum ice size allowed by GFDL MP scheme - reice_max = 150.0 ! Maximum ice size allowed by GFDL MP scheme - ! NOTE: When using RRTMGP cloud-optics, the min/max particle size allowed are imported - ! from initialization. - - public GFS_rrtmgp_gfdlmp_pre_init, GFS_rrtmgp_gfdlmp_pre_run, GFS_rrtmgp_gfdlmp_pre_finalize - -contains - ! ###################################################################################### - ! ###################################################################################### - subroutine GFS_rrtmgp_gfdlmp_pre_init() - end subroutine GFS_rrtmgp_gfdlmp_pre_init - - ! ###################################################################################### - ! ###################################################################################### -!! \section arg_table_GFS_rrtmgp_gfdlmp_pre_run -!! \htmlinclude GFS_rrtmgp_gfdlmp_pre_run.html -!! - subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & - i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, doSWrad, doLWrad, effr_in, kdt, & - do_mynnedmf, p_lev, p_lay, tv_lay, effrin_cldliq, effrin_cldice, effrin_cldrain, & - effrin_cldsnow, tracer, con_g, con_rd, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, errmsg, errflg) - implicit none - - ! Inputs - integer, intent(in) :: & - nCol, & ! Number of horizontal grid points - nLev, & ! Number of vertical layers - ncnd, & ! Number of cloud condensation types. - nTracers, & ! Number of tracers from model. - i_cldliq, & ! Index into tracer array for cloud liquid. - i_cldice, & ! Index into tracer array for cloud ice. - i_cldrain, & ! Index into tracer array for cloud rain. - i_cldsnow, & ! Index into tracer array for cloud snow. - i_cldgrpl, & ! Index into tracer array for cloud groupel. - i_cldtot, & ! Index into tracer array for cloud total amount. - kdt ! Current forecast iteration - logical, intent(in) :: & - doSWrad, & ! Call SW radiation? - doLWrad, & ! Call LW radiation - effr_in, & ! Provide hydrometeor radii from macrophysics? - do_mynnedmf, & ! Flag to activate MYNN-EDMF - doGP_cldoptics_LUT, & ! Flag to do GP cloud-optics (LUTs) - doGP_cldoptics_PADE ! (PADE approximation) - real(kind_phys), intent(in) :: & - con_g, & ! Physical constant: gravitational constant - con_rd ! Physical constant: gas-constant for dry air - real(kind_phys), dimension(:,:), intent(in) :: & - tv_lay, & ! Virtual temperature (K) - p_lay, & ! Pressure at model-layers (Pa) - effrin_cldliq, & ! Effective radius for liquid cloud-particles (microns) - effrin_cldice, & ! Effective radius for ice cloud-particles (microns) - effrin_cldrain, & ! Effective radius for rain cloud-particles (microns) - effrin_cldsnow ! Effective radius for snow cloud-particles (microns) - real(kind_phys), dimension(:,:), intent(in) :: & - p_lev ! Pressure at model-level interfaces (Pa) - real(kind_phys), dimension(:,:,:),intent(in) :: & - tracer ! Cloud condensate amount in layer by type () - - ! Outputs - real(kind_phys), dimension(:,:),intent(inout) :: & - cld_frac, & ! Total cloud fraction - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effecive radius - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - precip_frac ! Precipitation fraction - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - - ! Local variables - real(kind_phys) :: tem1,pfac - real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate - integer :: iCol,iLay,l,ncndl - real(kind_phys), dimension(nCol,nLev) :: deltaP,deltaZ - - if (.not. (doSWrad .or. doLWrad)) return - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Test inputs - if (ncnd .ne. 5) then - errmsg = 'Incorrect number of cloud condensates provided' - errflg = 1 - call check_error_msg('GFS_rrtmgp_gfdlmp_pre_run',errmsg) - return - endif - - ! Initialize outputs - cld_reliq(:,:) = reliq_def - cld_reice(:,:) = reice_def - cld_rerain(:,:) = rerain_def - cld_resnow(:,:) = resnow_def - - ! #################################################################################### - ! Pull out cloud information for GFDL MP scheme. - ! #################################################################################### - ! Condensate - cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water - cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water - cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain water - cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel - tracer(1:nCol,1:nLev,i_cldgrpl) - - ! Cloud water path (g/m2) - deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. - do iLay = 1, nLev - do iCol = 1, nCol - ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) - tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) - cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) - cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) - cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) - cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) - enddo - enddo - - ! Particle size - do iLay = 1, nLev - do iCol = 1, nCol - ! Use radii provided from the macrophysics - if (effr_in) then - cld_reliq(iCol,iLay) = effrin_cldliq(iCol,iLay) - cld_reice(iCol,iLay) = max(reice_min, min(reice_max,effrin_cldice(iCol,iLay))) - cld_rerain(iCol,iLay) = effrin_cldrain(iCol,iLay) - cld_resnow(iCol,iLay) = effrin_cldsnow(iCol,iLay) - endif - enddo - enddo - - ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from - ! 2.5 - 21.5 microns for liquid clouds, - ! 10 - 180 microns for ice-clouds - if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - where(cld_reliq .lt. radliq_lwr) cld_reliq = radliq_lwr - where(cld_reliq .gt. radliq_upr) cld_reliq = radliq_upr - where(cld_reice .lt. radice_lwr) cld_reice = radice_lwr - where(cld_reice .gt. radice_upr) cld_reice = radice_upr - endif - - ! Cloud-fraction. For mynnedmf, cld_frac is adjusted for precipitation here, otherwise - ! it passes through this interface. It is adjusted prior in sgscloudradpre. - if (do_mynnedmf .and. kdt .gt. 1) then - do iLay = 1, nLev - do iCol = 1, nCol - if (tracer(iCol,iLay,i_cldrain) > 1.0e-7 .OR. tracer(iCol,iLay,i_cldsnow)>1.0e-7) then - cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) - endif - enddo - enddo - else - cld_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) - endif - - ! Precipitation fraction (Hack. For now use cloud-fraction) - precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) - - end subroutine GFS_rrtmgp_gfdlmp_pre_run - - ! ######################################################################################### - ! ######################################################################################### - subroutine GFS_rrtmgp_gfdlmp_pre_finalize() - end subroutine GFS_rrtmgp_gfdlmp_pre_finalize -end module GFS_rrtmgp_gfdlmp_pre diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.meta b/physics/GFS_rrtmgp_gfdlmp_pre.meta deleted file mode 100644 index c45054613..000000000 --- a/physics/GFS_rrtmgp_gfdlmp_pre.meta +++ /dev/null @@ -1,303 +0,0 @@ -[ccpp-table-properties] - name = GFS_rrtmgp_gfdlmp_pre - type = scheme - dependencies = radiation_tools.F90, radiation_cloud_overlap.F90, rrtmgp_lw_cloud_optics.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmgp_gfdlmp_pre_run - type = scheme -[nCol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nTracers] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ncnd] - standard_name = number_of_condensate_species - long_name = number of cloud condensate types - units = count - dimensions = () - type = integer - intent = in -[i_cldliq] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[i_cldice] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[i_cldrain] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[i_cldsnow] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[i_cldgrpl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[i_cldtot] - standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[effr_in] - standard_name = flag_for_cloud_effective_radii - long_name = flag for cloud effective radii calculations in GFDL microphysics - units = flag - dimensions = () - type = logical - intent = in -[kdt] - standard_name = index_of_timestep - long_name = current forecast iteration - units = index - dimensions = () - type = integer - 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 -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure at vertical interface for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure at vertical layer for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tv_lay] - standard_name = virtual_temperature - long_name = layer virtual temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldliq] - standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle - long_name = eff. radius of cloud liquid water particle in micrometer - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldice] - standard_name = effective_radius_of_stratiform_cloud_ice_particle - long_name = eff. radius of cloud ice water particle in micrometer - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldrain] - standard_name = effective_radius_of_stratiform_cloud_rain_particle - long_name = effective radius of cloud rain particle in micrometers - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldsnow] - standard_name = effective_radius_of_stratiform_cloud_snow_particle - long_name = effective radius of cloud snow particle in micrometers - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_rd] - standard_name = gas_constant_of_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_lwp] - standard_name = cloud_liquid_water_path - long_name = layer cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_reliq] - standard_name = mean_effective_radius_for_liquid_cloud - long_name = mean effective radius for liquid cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_iwp] - standard_name = cloud_ice_water_path - long_name = layer cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_reice] - standard_name = mean_effective_radius_for_ice_cloud - long_name = mean effective radius for ice cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_swp] - standard_name = cloud_snow_water_path - long_name = layer cloud snow water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_resnow] - standard_name = mean_effective_radius_for_snow_flake - long_name = mean effective radius for snow cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_rwp] - standard_name = cloud_rain_water_path - long_name = layer cloud rain water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_rerain] - standard_name = mean_effective_radius_for_rain_drop - long_name = mean effective radius for rain cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - 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 - 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/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 deleted file mode 100644 index 85877704f..000000000 --- a/physics/GFS_rrtmgp_thompsonmp_pre.F90 +++ /dev/null @@ -1,291 +0,0 @@ -! ######################################################################################## -! This module contains the interface between the THOMPSON macrophysics and the RRTMGP radiation -! schemes. Only compatable with Model%imp_physics = Model%imp_physics_thompson -! ######################################################################################## -module GFS_rrtmgp_thompsonmp_pre - use machine, only: & - kind_phys - use radiation_tools, only: & - check_error_msg - use module_mp_thompson, only: & - calc_effectRad, Nt_c, & - re_qc_min, re_qc_max, & - re_qi_min, re_qi_max, & - re_qs_min, re_qs_max - use module_mp_thompson_make_number_concentrations, only: & - make_IceNumber, & - make_DropletNumber, & - make_RainNumber - use rrtmgp_lw_cloud_optics, only: radliq_lwr => radliq_lwrLW, radliq_upr => radliq_uprLW,& - radice_lwr => radice_lwrLW, radice_upr => radice_uprLW - implicit none - - ! Parameters specific to THOMPSON MP scheme. - real(kind_phys), parameter :: & - rerain_def = 1000.0 ! Default rain radius to 1000 microns - - public GFS_rrtmgp_thompsonmp_pre_init, GFS_rrtmgp_thompsonmp_pre_run, GFS_rrtmgp_thompsonmp_pre_finalize - -contains - ! ###################################################################################### - ! ###################################################################################### - subroutine GFS_rrtmgp_thompsonmp_pre_init() - end subroutine GFS_rrtmgp_thompsonmp_pre_init - - ! ###################################################################################### - ! ###################################################################################### -!! \section arg_table_GFS_rrtmgp_thompsonmp_pre_run -!! \htmlinclude GFS_rrtmgp_thompsonmp_pre_run.html -!! - subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, doLWrad, & - i_cldliq, i_cldice, i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, & - i_cldice_nc, i_twa, effr_in, p_lev, p_lay, tv_lay, t_lay, effrin_cldliq, & - effrin_cldice, effrin_cldsnow, tracer, qs_lay, q_lay, relhum, con_g, con_rd, & - con_eps, lmfshal, ltaerosol, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, & - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, errmsg, errflg) - - ! Inputs - integer, intent(in) :: & - nCol, & ! Number of horizontal grid points - nLev, & ! Number of vertical layers - ncnd, & ! Number of cloud condensation types. - nTracers, & ! Number of tracers from model. - i_cldliq, & ! Index into tracer array for cloud liquid amount. - i_cldice, & ! cloud ice amount. - i_cldrain, & ! cloud rain amount. - i_cldsnow, & ! cloud snow amount. - i_cldgrpl, & ! cloud groupel amount. - i_cldtot, & ! cloud total amount. - i_cldliq_nc, & ! cloud liquid number concentration. - i_cldice_nc, & ! cloud ice number concentration. - i_twa, & ! water friendly aerosol. - imfdeepcnv, & ! Choice of mass-flux deep convection scheme - imfdeepcnv_gf ! Flag for Grell-Freitas deep convection scheme - logical, intent(in) :: & - doSWrad, & ! Call SW radiation? - doLWrad, & ! Call LW radiation - effr_in, & ! Use cloud effective radii provided by model? - lmfshal, & ! Flag for mass-flux shallow convection scheme used by Xu-Randall - ltaerosol, & ! Flag for aerosol option - do_mynnedmf, & ! Flag to activate MYNN-EDMF - doGP_cldoptics_LUT,& ! Flag to do GP cloud-optics (LUTs) - doGP_cldoptics_PADE ! (PADE approximation) - real(kind_phys), intent(in) :: & - con_g, & ! Physical constant: gravitational constant - con_rd, & ! Physical constant: gas-constant for dry air - con_eps ! Physical constant: gas constant air / gas constant H2O - - real(kind_phys), dimension(:,:), intent(in) :: & - tv_lay, & ! Virtual temperature (K) - t_lay, & ! Temperature (K) - qs_lay, & ! Saturation vapor pressure (Pa) - q_lay, & ! water-vapor mixing ratio (kg/kg) - relhum, & ! Relative humidity - p_lay ! Pressure at model-layers (Pa) - real(kind_phys), dimension(:,:), intent(in) :: & - p_lev ! Pressure at model-level interfaces (Pa) - real(kind_phys), dimension(:,:,:),intent(in) :: & - tracer ! Cloud condensate amount in layer by type () - - ! In/Outs - real(kind_phys), dimension(:,:), intent(inout) :: & - cld_frac, & ! Total cloud fraction - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effecive radius - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - precip_frac, & ! Precipitation fraction - effrin_cldliq, & ! Effective radius for liquid cloud-particles (microns) - effrin_cldice, & ! Effective radius for ice cloud-particles (microns) - effrin_cldsnow ! Effective radius for snow cloud-particles (microns) - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - - ! Local variables - real(kind_phys) :: alpha0, pfac, tem1, cld_mr - real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate - integer :: iCol,iLay,l - real(kind_phys) :: rho, orho - real(kind_phys), dimension(nCol,nLev) :: deltaP, deltaZ, re_cloud, re_ice,& - re_snow, qv_mp, qc_mp, qi_mp, qs_mp, nc_mp, ni_mp, nwfa - logical :: top_at_1 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. (doSWrad .or. doLWrad)) return - - ! Cloud condensate - cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water - cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water - cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain water - cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel - tracer(1:nCol,1:nLev,i_cldgrpl) - - ! Cloud water path (g/m2) - deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. - do iLay = 1, nLev - do iCol = 1, nCol - ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) - tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) - cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) - cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) - cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) - cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) - enddo - enddo - - ! Cloud particle sizes and number concentrations... - - ! Prepare cloud mixing-ratios and number concentrations for calc_effectRad, - ! and update number concentrations, consistent with sub-grid clouds - do iLay = 1, nLev - do iCol = 1, nCol - qv_mp(iCol,iLay) = q_lay(iCol,iLay)/(1.-q_lay(iCol,iLay)) - rho = con_eps*p_lay(iCol,iLay)/(con_rd*t_lay(iCol,iLay)*(qv_mp(iCol,iLay)+con_eps)) - orho = 1./rho - qc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq) / (1.-q_lay(iCol,iLay)) - qi_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice) / (1.-q_lay(iCol,iLay)) - qs_mp(iCol,iLay) = tracer(iCol,iLay,i_cldsnow) / (1.-q_lay(iCol,iLay)) - ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) - if (ltaerosol) then - nc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq_nc) / (1.-q_lay(iCol,iLay)) - nwfa(iCol,iLay) = tracer(iCol,iLay,i_twa) - if (qc_mp(iCol,iLay) > 1.e-12 .and. nc_mp(iCol,iLay) < 100.) then - nc_mp(iCol,iLay) = make_DropletNumber(qc_mp(iCol,iLay)*rho, nwfa(iCol,iLay)*rho) * orho - endif - else - nc_mp(iCol,iLay) = nt_c*orho - endif - if (qi_mp(iCol,iLay) > 1.e-12 .and. ni_mp(iCol,iLay) < 100.) then - ni_mp(iCol,iLay) = make_IceNumber(qi_mp(iCol,iLay)*rho, t_lay(iCol,iLay)) * orho - endif - enddo - enddo - - ! Compute effective radii for liquid/ice/snow using subgrid scale clouds - ! Call Thompson's subroutine to compute effective radii - do iCol=1,nCol - call calc_effectRad (t_lay(iCol,:), p_lay(iCol,:), qv_mp(iCol,:), qc_mp(iCol,:), & - nc_mp(iCol,:), qi_mp(iCol,:), ni_mp(iCol,:), qs_mp(iCol,:), & - re_cloud(iCol,:), re_ice(iCol,:), re_snow(iCol,:), 1, nLev ) - do iLay = 1, nLev - re_cloud(iCol,iLay) = MAX(re_qc_min, MIN(re_cloud(iCol,iLay), re_qc_max)) - re_ice(iCol,iLay) = MAX(re_qi_min, MIN(re_ice(iCol,iLay), re_qi_max)) - re_snow(iCol,iLay) = MAX(re_qs_min, MIN(re_snow(iCol,iLay), re_qs_max)) - enddo - enddo - - ! Scale Thompson's effective radii from meter to micron - do iLay = 1, nLev - do iCol = 1, nCol - effrin_cldliq(iCol,iLay) = re_cloud(iCol,iLay)*1.e6 - effrin_cldice(iCol,iLay) = re_ice(iCol,iLay)*1.e6 - effrin_cldsnow(iCol,iLay) = re_snow(iCol,iLay)*1.e6 - enddo - enddo - - ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from - ! 2.5 - 21.5 microns for liquid clouds, - ! 10 - 180 microns for ice-clouds - if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - do iLay = 1, nLev - do iCol = 1, nCol - if (effrin_cldliq(iCol,iLay) .lt. radliq_lwr) effrin_cldliq(iCol,iLay) = radliq_lwr - if (effrin_cldliq(iCol,iLay) .gt. radliq_upr) effrin_cldliq(iCol,iLay) = radliq_upr - if (effrin_cldice(iCol,iLay) .lt. radice_lwr) effrin_cldice(iCol,iLay) = radice_lwr - if (effrin_cldice(iCol,iLay) .gt. radice_upr) effrin_cldice(iCol,iLay) = radice_upr - enddo - enddo - endif - - ! Update global effective radii arrays. - do iLay = 1, nLev - do iCol = 1, nCol - cld_reliq(iCol,iLay) = effrin_cldliq(iCol,iLay) - cld_reice(iCol,iLay) = effrin_cldice(iCol,iLay) - cld_resnow(iCol,iLay) = effrin_cldsnow(iCol,iLay) - cld_rerain(iCol,iLay) = rerain_def - enddo - enddo - ! Compute cloud-fraction. Else, use value provided - if(.not. do_mynnedmf .and. imfdeepcnv .ne. imfdeepcnv_gf ) then ! MYNN PBL or GF conv - ! Cloud-fraction - if( lmfshal) alpha0 = 100. ! Default (from GATE simulations) - if(.not. lmfshal) alpha0 = 2000. - ! Xu-Randall (1996) cloud-fraction - do iLay = 1, nLev - do iCol = 1, nCol - cld_mr = cld_condensate(iCol,iLay,1) + cld_condensate(iCol,iLay,2) + & - cld_condensate(iCol,iLay,4) - cld_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & - qs_lay(iCol,iLay), relhum(iCol,iLay), cld_mr, alpha0) - enddo - enddo - endif - - ! Precipitation fraction (Hack. For now use cloud-fraction) - precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) - - end subroutine GFS_rrtmgp_thompsonmp_pre_run - - ! ###################################################################################### - ! ###################################################################################### - subroutine GFS_rrtmgp_thompsonmp_pre_finalize() - end subroutine GFS_rrtmgp_thompsonmp_pre_finalize - - ! ###################################################################################### - ! This function computes the cloud-fraction following. - ! Xu-Randall(1996) A Semiempirical Cloudiness Parameterization for Use in Climate Models - ! https://doi.org/10.1175/1520-0469(1996)053<3084:ASCPFU>2.0.CO;2 - ! - ! cld_frac = {1-exp[-alpha*cld_mr/((1-relhum)*qs_lay)**lambda]}*relhum**P - ! - ! ###################################################################################### - function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) - - ! Inputs - real(kind_phys), intent(in) :: & - p_lay, & ! Pressure (Pa) - qs_lay, & ! Saturation vapor-pressure (Pa) - relhum, & ! Relative humidity - cld_mr, & ! Total cloud mixing ratio - alpha ! Scheme parameter (default=100) - - ! Outputs - real(kind_phys) :: cld_frac_XuRandall - - ! Locals - real(kind_phys) :: clwt, clwm, onemrh, tem1, tem2, tem3 - - ! Parameters - real(kind_phys) :: & - lambda = 0.50, & ! - P = 0.25 - - clwt = 1.0e-6 * (p_lay*0.001) - if (cld_mr > clwt) then - onemrh = max(1.e-10, 1.0 - relhum) - tem1 = alpha / min(max((onemrh*qs_lay)**lambda,0.0001),1.0) - tem2 = max(min(tem1*(cld_mr - clwt), 50.0 ), 0.0 ) - tem3 = sqrt(sqrt(relhum)) ! This assumes "p" = 0.25. Identical, but cheaper than relhum**p - ! - cld_frac_XuRandall = max( tem3*(1.0-exp(-tem2)), 0.0 ) - else - cld_frac_XuRandall = 0.0 - endif - - return - end function -end module GFS_rrtmgp_thompsonmp_pre diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.meta b/physics/GFS_rrtmgp_thompsonmp_pre.meta deleted file mode 100644 index ff8d0e13b..000000000 --- a/physics/GFS_rrtmgp_thompsonmp_pre.meta +++ /dev/null @@ -1,377 +0,0 @@ -[ccpp-table-properties] - name = GFS_rrtmgp_thompsonmp_pre - type = scheme - dependencies = radiation_tools.F90, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90, rrtmgp_lw_cloud_optics.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmgp_thompsonmp_pre_run - type = scheme -[nCol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nTracers] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ncnd] - standard_name = number_of_condensate_species - long_name = number of cloud condensate types - units = count - dimensions = () - type = integer - intent = in -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[i_cldliq] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[i_cldice] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[i_cldrain] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[i_cldsnow] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[i_cldgrpl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[i_cldtot] - standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in -[i_cldliq_nc] - standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array - long_name = tracer index for liquid number concentration - units = index - dimensions = () - type = integer - intent = in -[i_cldice_nc] - standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array - long_name = tracer index for ice number concentration - units = index - dimensions = () - type = integer - intent = in -[i_twa] - standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array - long_name = tracer index for water friendly aerosol - units = index - dimensions = () - type = integer - intent = in -[effr_in] - standard_name = flag_for_cloud_effective_radii - long_name = flag for cloud effective radii calculations in GFDL microphysics - units = flag - dimensions = () - type = logical - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure at vertical interface for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure at vertical layer for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tv_lay] - standard_name = virtual_temperature - long_name = layer virtual temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature at vertical layer for radiation calculation - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldliq] - standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle - long_name = eff. radius of cloud liquid water particle in micrometer - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[effrin_cldice] - standard_name = effective_radius_of_stratiform_cloud_ice_particle - long_name = eff. radius of cloud ice water particle in micrometer - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[effrin_cldsnow] - standard_name = effective_radius_of_stratiform_cloud_snow_particle - long_name = effective radius of cloud snow particle in micrometers - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[qs_lay] - standard_name = saturation_vapor_pressure - long_name = saturation vapor pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[q_lay] - standard_name = water_vapor_mixing_ratio - long_name = water vaport mixing ratio - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[relhum] - standard_name = relative_humidity - long_name = layer relative humidity - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_rd] - standard_name = gas_constant_of_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_eps] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants - long_name = rd/rv - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[lmfshal] - standard_name = flag_for_cloud_area_fraction_option_for_radiation - long_name = flag for lmfshal - units = flag - dimensions = () - type = logical - intent = in -[ltaerosol] - standard_name = flag_for_aerosol_physics - long_name = flag for aerosol physics - units = flag - dimensions = () - type = logical - 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 -[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 -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_lwp] - standard_name = cloud_liquid_water_path - long_name = layer cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_reliq] - standard_name = mean_effective_radius_for_liquid_cloud - long_name = mean effective radius for liquid cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_iwp] - standard_name = cloud_ice_water_path - long_name = layer cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_reice] - standard_name = mean_effective_radius_for_ice_cloud - long_name = mean effective radius for ice cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_swp] - standard_name = cloud_snow_water_path - long_name = layer cloud snow water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_resnow] - standard_name = mean_effective_radius_for_snow_flake - long_name = mean effective radius for snow cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_rwp] - standard_name = cloud_rain_water_path - long_name = layer cloud rain water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_rerain] - standard_name = mean_effective_radius_for_rain_drop - long_name = mean effective radius for rain cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - 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 - 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/GFS_rrtmgp_zhaocarr_pre.F90 b/physics/GFS_rrtmgp_zhaocarr_pre.F90 deleted file mode 100644 index d7eecd090..000000000 --- a/physics/GFS_rrtmgp_zhaocarr_pre.F90 +++ /dev/null @@ -1,253 +0,0 @@ -! ######################################################################################## -! This module contains the interface between the Zhao-Carr macrophysics and the RRTMGP -! radiation schemes. Only compatable with imp_physics = imp_physics_zhaocarr -! ######################################################################################## -module GFS_rrtmgp_zhaocarr_pre - use machine, only: kind_phys - use radiation_tools, only: check_error_msg - use funcphys, only: fpvs - use module_radiation_clouds, only: get_alpha_dcorr - - ! Zhao-Carr MP parameters. - real(kind_phys), parameter :: & - reliq_def = 10.0 , & ! Default liq radius to 10 micron - reice_def = 50.0, & ! Default ice radius to 50 micron - rerain_def = 1000.0, & ! Default rain radius to 1000 micron - resnow_def = 250.0 ! Default snow radius to 250 micron - - public GFS_rrtmgp_zhaocarr_pre_init, GFS_rrtmgp_zhaocarr_pre_run, GFS_rrtmgp_zhaocarr_pre_finalize - -contains - ! ###################################################################################### - ! ###################################################################################### - subroutine GFS_rrtmgp_zhaocarr_pre_init() - end subroutine GFS_rrtmgp_zhaocarr_pre_init - - ! ###################################################################################### - ! ###################################################################################### -!! \section arg_table_GFS_rrtmgp_zhaocarr_pre_run -!! \htmlinclude GFS_rrtmgp_zhaocarr_pre_run.html -!! - subroutine GFS_rrtmgp_zhaocarr_pre_run(nCol, nLev, nCnd, nTracers, i_cldliq, lsswr, & - lslwr, effr_in, uni_cld, lmfshal, lat, lsmask, p_lev, p_lay, t_lay, relhum, & - tv_lay, effrin_cldliq, effrin_cldice, effrin_cldrain, effrin_cldsnow, & - shoc_sgs_cldfrac, cncvw, tracer, & - con_ttp, con_epsq, con_epsqs, con_eps, con_epsm1, con_g, con_rd, con_pi, & - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, deltaZ, de_lgth, cloud_overlap_param, errmsg, errflg) - implicit none - - ! Inputs - integer, intent(in) :: & - nCol, & ! Number of horizontal grid points - nLev, & ! Number of vertical layers - nCnd, & ! Number of cloud condensation types. - nTracers, & ! Number of tracers from model. - i_cldliq ! Index into tracer array for cloud liquid. - logical, intent(in) :: & - lsswr, & ! Call SW radiation? - lslwr, & ! Call LW radiation - effr_in, & ! Provide hydrometeor radii from macrophysics? - uni_cld, & ! - lmfshal - real(kind_phys), intent(in) :: & - con_eps, & ! rd/rv - con_epsm1, & ! (rd/rv) - 1 - con_epsq, & ! Floor value for specific humidity - con_epsqs, & ! Floor value for saturation mixing ratio - con_g, & ! Gravitational acceleration (m/s2) - con_ttp, & ! Triple point temperature of water (K) - con_rd, & ! Ideal gas constant for dry air (J/kg/K) - con_pi ! Pi - real(kind_phys), dimension(:), intent(in) :: & - lsmask, & ! Land/Sea mask - lat ! Latitude - real(kind_phys), dimension(:, :), intent(in) :: & - tv_lay, & ! Virtual temperature (K) - p_lay, & ! Pressure at model-layers (Pa) - t_lay, & ! Temperature at model-layers (K) - relhum, & ! Relative humidity at model-layers () - effrin_cldliq, & ! Effective radius for liquid cloud-particles (microns) - effrin_cldice, & ! Effective radius for ice cloud-particles (microns) - effrin_cldrain, & ! Effective radius for rain cloud-particles (microns) - effrin_cldsnow, & ! Effective radius for snow cloud-particles (microns) - shoc_sgs_cldfrac, & ! Subgrid-scale cloud fraction from the SHOC scheme - cncvw ! Convective cloud water mixing ratio (kg/kg) - real(kind_phys), dimension(:, :), intent(in) :: & - p_lev ! Pressure at model-level interfaces (Pa) - real(kind_phys), dimension(:, :, :),intent(in) :: & - tracer ! Cloud condensate amount in layer by type () - - ! Outputs - real(kind_phys), dimension(:),intent(out) :: & - de_lgth ! Decorrelation length - real(kind_phys), dimension(:, :),intent(out) :: & - cld_frac, & ! Total cloud fraction - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effecive radius - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - deltaZ, & ! Layer thickness (km) - cloud_overlap_param ! Cloud-overlap parameter - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - - ! Local variables - real(kind_phys) :: tem1,tem2,tem3,clwt,onemrh,clwm,clwmin,es,qs,value - real(kind_phys), dimension(nCol, nLev, min(4,nCnd)) :: cld_condensate - integer :: iCol,iLay - real(kind_phys), dimension(nCol,nLev) :: deltaP - - if (.not. (lsswr .or. lslwr)) return - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Initialize outputs - cld_lwp(:,:) = 0.0 - cld_reliq(:,:) = 0.0 - cld_iwp(:,:) = 0.0 - cld_reice(:,:) = 0.0 - cld_rwp(:,:) = 0.0 - cld_rerain(:,:) = 0.0 - cld_swp(:,:) = 0.0 - cld_resnow(:,:) = 0.0 - - ! #################################################################################### - ! Pull out cloud information for Zhao-Carr MP scheme. - ! #################################################################################### - ! Condensate - cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! Liquid water - - ! Set really tiny suspended particle amounts to clear - do iLay=1,nLev - do iCol=1,nCol - if (cld_condensate(iCol,iLay,1) < con_epsq) cld_condensate(iCol,iLay,1) = 0.0 - enddo - enddo - - ! Use radii provided from the macrophysics? - if (effr_in) then - cld_reliq(1:nCol,1:nLev) = effrin_cldliq(1:nCol,1:nLev) - cld_reice(1:nCol,1:nLev) = effrin_cldice(1:nCol,1:nLev) - cld_rerain(1:nCol,1:nLev) = effrin_cldrain(1:nCol,1:nLev) - cld_resnow(1:nCol,1:nLev) = effrin_cldsnow(1:nCol,1:nLev) - endif - - ! Use cloud-fraction from SHOC? - if (uni_cld) then - cld_frac(1:nCol,1:nLev) = shoc_sgs_cldfrac(1:nCol,1:nLev) - ! Compute cloud-fraction? - else - clwmin = 0.0e-6 - if (.not. lmfshal) then - do iLay = 1,nLev - do iCol = 1, nCol - es = min( p_lay(iCol,iLay), fpvs( t_lay(iCol,iLay) ) ) ! fpvs and prsl in pa - qs = max( con_epsqs, con_eps * es / (p_lay(iCol,iLay) + con_epsm1*es) ) - clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.00001) - if (cld_condensate(iCol,iLay,1) > clwt) then - onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) - clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.00001 ) - tem1 = min(max(sqrt(sqrt(onemrh*qs)),0.0001),1.0) - tem1 = 2000.0 / tem1 - value = max( min( tem1*(cld_condensate(iCol,iLay,1)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) - cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - else - do iLay=1,nLev - do iCol = 1, nCol - es = min( p_lay(iCol,iLay), fpvs( t_lay(iCol,iLay) ) ) ! fpvs and prsl in pa - qs = max( con_epsqs, con_eps * es / (p_lay(iCol,iLay) + con_epsm1*es) ) - clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.00001) - if (cld_condensate(iCol,iLay,1) > clwt) then - onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) - clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.00001 ) - tem1 = min(max((onemrh*qs)**0.49,0.0001),1.0) !jhan - tem1 = 100.0 / tem1 - value = max( min( tem1*(cld_condensate(iCol,iLay,1)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) - cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - endif - endif - - ! Add suspended convective cloud water to grid-scale cloud water only for cloud - ! fraction & radiation computation it is to enhance cloudiness due to suspended convec - ! cloud water for zhao/moorthi's (imp_phys=99) - cld_condensate(1:nCol,1:nLev,1) = cld_condensate(1:nCol,1:nLev,1) + cncvw(1:nCol,1:nLev) - - ! Compute cloud liquid/ice condensate path. - deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. - do iLay=1,nLev - do iCol=1,nCol - tem1 = max(0.0, cld_condensate(iCol,iLay,1)) * (1.0e5/con_g) * deltaP(iCol,iLay) - cld_iwp(iCol,iLay) = tem1*(t_lay(iCol,iLay) - 273.16) - cld_lwp(iCol,iLay) = tem1 - cld_iwp(iCol,iLay) - enddo - enddo - - ! Compute effective liquid cloud droplet radius over land. - if(.not. effr_in) then - do iCol = 1, nCol - if (nint(lsmask(iCol)) == 1) then - do iLay = 1, nLev - cld_reliq(iCol,iLay) = 5.0 + 5.0 * (t_lay(iCol,iLay) - 273.16) - enddo - endif - enddo - - ! Compute effective ice cloud droplet radius following Heymsfield - ! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. - do iLay=1,nLev - do iCol=1,nCol - tem2 = t_lay(iCol,iLay) - con_ttp - if (cld_iwp(iCol,iLay) > 0.0) then - tem3 = (con_g/con_rd ) * cld_iwp(iCol,iLay) * (0.01*p_lay(iCol,iLay)) / (deltaP(iCol,iLay)*tv_lay(iCol,iLay)) - if (tem2 < -50.0) then - cld_reice(iCol,iLay) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem2 < -40.0) then - cld_reice(iCol,iLay) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem2 < -30.0) then - cld_reice(iCol,iLay) = (1250.0/9.208) * tem3 ** 0.055 - else - cld_reice(iCol,iLay) = (1250.0/9.387) * tem3 ** 0.031 - endif - cld_reice(iCol,iLay) = max(10.0, min(cld_reice(iCol,iLay), 150.0)) - endif - enddo - enddo - endif - - ! #################################################################################### - ! Cloud (and precipitation) overlap ! #################################################################################### - ! Compute layer-thickness - do iCol=1,nCol - do iLay=1,nLev - deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) * tv_lay(iCol,iLay) - enddo - enddo - - ! Cloud overlap parameter - call get_alpha_dcorr(nCol, nLev, lat, con_pi, deltaZ, de_lgth, cloud_overlap_param) - - end subroutine GFS_rrtmgp_zhaocarr_pre_run - - ! ######################################################################################### - ! ######################################################################################### - subroutine GFS_rrtmgp_zhaocarr_pre_finalize() - end subroutine GFS_rrtmgp_zhaocarr_pre_finalize - -end module GFS_rrtmgp_zhaocarr_pre diff --git a/physics/GFS_rrtmgp_zhaocarr_pre.meta b/physics/GFS_rrtmgp_zhaocarr_pre.meta deleted file mode 100644 index 2eb333115..000000000 --- a/physics/GFS_rrtmgp_zhaocarr_pre.meta +++ /dev/null @@ -1,366 +0,0 @@ -[ccpp-table-properties] - name = GFS_rrtmgp_zhaocarr_pre - type = scheme - dependencies = radiation_tools.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmgp_zhaocarr_pre_run - type = scheme -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[ncnd] - standard_name = number_of_condensate_species - long_name = number of cloud condensate types - units = count - dimensions = () - type = integer - intent = in -[nTracers] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[i_cldliq] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[lsswr] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[lslwr] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[effr_in] - standard_name = flag_for_cloud_effective_radii - long_name = flag for cloud effective radii calculations in GFDL microphysics - units = flag - dimensions = () - type = logical - intent = in -[uni_cld] - standard_name = flag_for_shoc_cloud_area_fraction_for_radiation - long_name = flag for uni_cld - units = flag - dimensions = () - type = logical - intent = in -[lmfshal] - standard_name = flag_for_cloud_area_fraction_option_for_radiation - long_name = flag for lmfshal - units = flag - dimensions = () - type = logical - intent = in -[lat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - intent = in - kind = kind_phys -[lsmask] - standard_name = area_type - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure at vertical interface for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure at vertical layer for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature at vertical layer for radiation calculation - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[relhum] - standard_name = relative_humidity - long_name = layer relative humidity - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tv_lay] - standard_name = virtual_temperature - long_name = layer virtual temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldliq] - standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle - long_name = eff. radius of cloud liquid water particle in micrometer - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldice] - standard_name = effective_radius_of_stratiform_cloud_ice_particle - long_name = eff. radius of cloud ice water particle in micrometer - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldrain] - standard_name = effective_radius_of_stratiform_cloud_rain_particle - long_name = effective radius of cloud rain particle in micrometers - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldsnow] - standard_name = effective_radius_of_stratiform_cloud_snow_particle - long_name = effective radius of cloud snow particle in micrometers - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[shoc_sgs_cldfrac] - standard_name = subgrid_scale_cloud_fraction_from_shoc - long_name = subgrid-scale cloud fraction from the SHOC scheme - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cncvw] - standard_name = convective_cloud_condensate_mixing_ratio - long_name = convective cloud water mixing ratio in the phy_f3d array - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[con_ttp] - standard_name = triple_point_temperature_of_water - long_name = triple point temperature of water - units = K - dimensions = () - type = real - kind = kind_phys - intent = in -[con_epsq] - standard_name = minimum_value_of_specific_humidity - long_name = floor value for specific humidity - units = kg kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_epsqs] - standard_name = minimum_value_of_saturation_mixing_ratio - long_name = floor value for saturation mixing ratio - units = kg kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_eps] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants - long_name = rd/rv - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[con_epsm1] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one - long_name = (rd/rv) - 1 - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_rd] - standard_name = gas_constant_of_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_pi] - standard_name = pi - long_name = ratio of a circle's circumference to its diameter - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_lwp] - standard_name = cloud_liquid_water_path - long_name = layer cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_reliq] - standard_name = mean_effective_radius_for_liquid_cloud - long_name = mean effective radius for liquid cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_iwp] - standard_name = cloud_ice_water_path - long_name = layer cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_reice] - standard_name = mean_effective_radius_for_ice_cloud - long_name = mean effective radius for ice cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_swp] - standard_name = cloud_snow_water_path - long_name = layer cloud snow water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_resnow] - standard_name = mean_effective_radius_for_snow_flake - long_name = mean effective radius for snow cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_rwp] - standard_name = cloud_rain_water_path - long_name = layer cloud rain water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_rerain] - standard_name = mean_effective_radius_for_rain_drop - long_name = mean effective radius for rain cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[deltaZ] - standard_name = layer_thickness - long_name = layer_thickness - units = m - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[de_lgth] - standard_name = cloud_decorrelation_length - long_name = cloud decorrelation length - units = km - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[cloud_overlap_param] - standard_name = cloud_overlap_param - long_name = cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - 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 From 5bb96c42fc535070714e43b4cef2072da0fb89db Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 3 Mar 2022 17:03:10 -0700 Subject: [PATCH 082/217] minor formatting --- physics/scm_sfc_flux_spec.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/scm_sfc_flux_spec.F90 b/physics/scm_sfc_flux_spec.F90 index a19f9abbb..fc4aaf5d1 100644 --- a/physics/scm_sfc_flux_spec.F90 +++ b/physics/scm_sfc_flux_spec.F90 @@ -60,15 +60,15 @@ subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, use machine, only: kind_phys - integer, intent(in) :: im, lkm + integer, intent(in) :: im, lkm integer, intent(inout) :: islmsk(:) - logical, intent(in) :: cplflx, cplice + logical, intent(in) :: cplflx, cplice logical, intent(inout) :: dry(:), icy(:), flag_cice(:), wet(:), use_flake(:) - real(kind=kind_phys), intent(in) :: u1(:), v1(:), z1(:), t1(:), q1(:), p1(:), roughness_length(:), & + real(kind=kind_phys), intent(in) :: cp, grav, hvap, rd, fvirt, vonKarman, min_seaice, tgice, min_lakeice + real(kind=kind_phys), intent(in) :: u1(:), v1(:), z1(:), t1(:), q1(:), p1(:), roughness_length(:), & spec_sh_flux(:), spec_lh_flux(:), exner_inverse(:), T_surf(:), oceanfrac(:), lakefrac(:), lakedepth(:) - real(kind=kind_phys), intent(in) :: cp, grav, hvap, rd, fvirt, vonKarman, min_seaice, tgice, min_lakeice real(kind=kind_phys), intent(inout) :: cice(:), tisfc(:), tsfcl(:), tsfc_wat(:), slmsk(:) - real(kind=kind_phys), intent(out) :: sh_flux(:), lh_flux(:), u_star(:), sfc_stress(:), & + real(kind=kind_phys), intent(out) :: sh_flux(:), lh_flux(:), u_star(:), sfc_stress(:), & cm(:), ch(:), fm(:), fh(:), rb(:), u10m(:), v10m(:), wind1(:), qss(:), t2m(:), q2m(:), & sh_flux_chs(:), frland(:) From dec5bbdf14dc96140b9d84c588c8cca6bb8deeb4 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 4 Mar 2022 21:57:08 +0000 Subject: [PATCH 083/217] Initial implementation of explicit coupling of convective (GF/SAMF) and pbl (MYNN) clouds to RRTMGP. --- physics/GFS_rrtmgp_cloud_mp.F90 | 413 +++++++++++++++----------- physics/GFS_rrtmgp_cloud_mp.meta | 119 +++++--- physics/GFS_rrtmgp_cloud_overlap.F90 | 10 +- physics/GFS_rrtmgp_cloud_overlap.meta | 22 +- physics/rrtmgp_lw_cloud_optics.F90 | 17 +- physics/rrtmgp_lw_cloud_optics.meta | 26 +- physics/rrtmgp_lw_cloud_sampling.F90 | 14 +- physics/rrtmgp_lw_cloud_sampling.meta | 22 +- physics/rrtmgp_lw_rte.F90 | 16 +- physics/rrtmgp_lw_rte.meta | 22 +- physics/rrtmgp_sw_cloud_optics.F90 | 17 +- physics/rrtmgp_sw_cloud_optics.meta | 26 +- physics/rrtmgp_sw_cloud_sampling.F90 | 14 +- physics/rrtmgp_sw_cloud_sampling.meta | 22 +- physics/rrtmgp_sw_rte.F90 | 16 +- physics/rrtmgp_sw_rte.meta | 22 +- 16 files changed, 500 insertions(+), 298 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index b57e54d44..6ae511326 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -37,17 +37,17 @@ end subroutine GFS_rrtmgp_cloud_mp_init ! ###################################################################################### subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, kdt, & - imfdeepcnv, imfdeepcnv_gf, doSWrad, doLWrad, effr_in, lmfshal, ltaerosol, icloud, & - imp_physics, imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & - imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, lgfdlmprad, & - imp_physics_fer_hires, do_mynnedmf, uni_cld, lmfdeep2, doGP_convcld, p_lev, & - p_lay, t_lay, qs_lay, q_lay, relhum, lsmask, xlon, xlat, dx, tv_lay, & - effrin_cldliq, effrin_cldice, effrin_cldrain, effrin_cldsnow, tracer, & - cnv_mixratio, cnv_cldfrac, qci_conv, deltaZ, deltaZc, deltaP, con_g, con_rd, & + imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, doSWrad, doLWrad, effr_in, lmfshal, & + ltaerosol, icloud, imp_physics, imp_physics_thompson, imp_physics_gfdl, & + lgfdlmprad, do_mynnedmf, uni_cld, lmfdeep2, p_lev, p_lay, t_lay, & + qs_lay, q_lay, relhum, lsmask, xlon, xlat, dx, tv_lay, effrin_cldliq, & + effrin_cldice, effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cld_cnv_frac,& + qci_conv, deltaZ, deltaZc, deltaP, qc_mynn, qi_mynn, cld_mynn_frac, con_g, con_rd,& con_eps, con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice, & - lwp_ex, iwp_ex, lwp_fc, iwp_fc, errmsg, errflg) + cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, & + cld_mynn_lwp, cld_mynn_reliq, cld_mynn_iwp, cld_mynn_reice, lwp_ex, iwp_ex, & + lwp_fc, iwp_fc, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -66,15 +66,11 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic i_twa, & ! water friendly aerosol. imfdeepcnv, & ! Choice of mass-flux deep convection scheme imfdeepcnv_gf, & ! Flag for Grell-Freitas deep convection scheme + imfdeepcnv_samf, & ! Flag for scale awware mass flux convection scheme kdt, & ! Current forecast iteration imp_physics, & ! Choice of microphysics scheme imp_physics_thompson, & ! Choice of Thompson imp_physics_gfdl, & ! Choice of GFDL - imp_physics_zhao_carr, & ! Choice of Zhao-Carr - imp_physics_zhao_carr_pdf, & ! Choice of Zhao-Carr + PDF clouds - imp_physics_mg, & ! Choice of Morrison-Gettelman - imp_physics_wsm6, & ! Choice of WSM6 - imp_physics_fer_hires, & ! Choice of Ferrier-Aligo icloud ! Control for cloud are fraction option logical, intent(in) :: & doSWrad, & ! Call SW radiation? @@ -86,7 +82,6 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic do_mynnedmf, & ! Flag to activate MYNN-EDMF uni_cld, & ! Flag for unified cloud scheme lmfdeep2, & ! Flag for mass flux deep convection - doGP_convcld, & ! Treat convective clouds seperately? doGP_cldoptics_LUT, & ! Flag to do GP cloud-optics (LUTs) doGP_cldoptics_PADE ! (PADE approximation) real(kind_phys), intent(in) :: & @@ -110,7 +105,10 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic qci_conv, & ! Convective cloud condesate after rainout (kg/kg) deltaZ, & ! Layer-thickness (m) deltaZc, & ! Layer-thickness, from layer centers (m) - deltaP ! Layer-thickness (Pa) + deltaP, & ! Layer-thickness (Pa) + qc_mynn, & ! + qi_mynn, & ! + cld_mynn_frac ! real(kind_phys), dimension(:,:), intent(inout) :: & effrin_cldliq, & ! Effective radius for stratiform liquid cloud-particles (microns) effrin_cldice, & ! Effective radius for stratiform ice cloud-particles (microns) @@ -129,21 +127,25 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic lwp_fc, & ! Total liquid water path from cloud fraction scheme iwp_fc ! Total ice water path from cloud fraction scheme real(kind_phys), dimension(:,:),intent(inout) :: & - cld_frac, & ! Total cloud fraction - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effecive radius - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius + cld_frac, & ! Cloud-fraction for stratiform clouds + cld_lwp, & ! Water path for stratiform liquid cloud-particles + cld_reliq, & ! Effective radius for stratiform liquid cloud-particles + cld_iwp, & ! Water path for stratiform ice cloud-particles + cld_reice, & ! Effective radius for stratiform ice cloud-particles + cld_swp, & ! Water path for snow hydrometeors + cld_resnow, & ! Effective radius for snow hydrometeors + cld_rwp, & ! Water path for rain hydrometeors + cld_rerain, & ! Effective radius for rain hydrometeors precip_frac, & ! Precipitation fraction - cnv_cldfrac, & ! Convective cloud-fraction (1) - cnv_cld_lwp, & ! Water path for convective liquid cloud-particles (microns) - cnv_cld_reliq, & ! Effective radius for convective liquid cloud-particles (microns) - cnv_cld_iwp, & ! Water path for convective ice cloud-particles (microns) - cnv_cld_reice ! Effective radius for convective ice cloud-particles (microns) + cld_cnv_frac, & ! Cloud-fraction for convective clouds + cld_cnv_lwp, & ! Water path for convective liquid cloud-particles + cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles + cld_cnv_iwp, & ! Water path for convective ice cloud-particles + cld_cnv_reice, & ! Effective radius for convective ice cloud-particles + cld_mynn_lwp, & ! Water path for MYNN SGS PBL liquid cloud-particles + cld_mynn_reliq, & ! Effective radius for MYNN SGS PBL liquid cloud-particles + cld_mynn_iwp, & ! Water path for MYNN SGS PBL ice cloud-particles + cld_mynn_reice ! Effective radius for MYNN SGS PBL ice cloud-particles character(len=*), intent(out) :: & errmsg ! Error message integer, intent(out) :: & @@ -151,7 +153,8 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic ! Local integer :: iCol, iLay - real (kind=kind_phys), dimension(nCol,nLev) :: cldcov, cldtot, cldcnv + real(kind_phys) :: alpha0 + real(kind_phys), dimension(nCol,nLev) :: cldcov, cldtot, cldcnv if (.not. (doSWrad .or. doLWrad)) return @@ -213,7 +216,29 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic ! Thompson Microphysics ! ################################################################################### if (imp_physics == imp_physics_thompson) then - ! Update particle size using modified mixing-ratios. + + ! MYNN-EDMF PBL clouds? + if(do_mynnedmf) then + call cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & + qc_mynn, qi_mynn, con_ttp, con_g, & + cld_mynn_lwp, cld_mynn_reliq, cld_mynn_iwp, cld_mynn_reice, cld_mynn_frac) + endif + + ! Grell-Freitas convective clouds? + if (imfdeepcnv == imfdeepcnv_gf) then + call cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & + qci_conv, con_ttp, con_g, & + cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_cnv_frac) + endif + + ! SAMF scale & aerosol-aware mass-flux convective clouds? + if (imfdeepcnv == imfdeepcnv_samf) then + call cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, & + cnv_mixratio, con_ttp, con_g, & + cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_cnv_frac) + endif + + ! Update particle size using modified mixing-ratios from Thompson. call cmp_reff_Thompson(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & i_cldliq_nc, i_twa, q_lay, p_lay, t_lay, tracer, con_eps, con_rd, ltaerosol,& effrin_cldliq, effrin_cldice, effrin_cldsnow) @@ -221,66 +246,12 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic cld_reice = effrin_cldice cld_resnow = effrin_cldsnow - ! - ! SGS clouds present, use cloud-fraction modified to include sgs clouds. - ! - if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then - if (icloud == 3) then - ! Call progcld_thompson - ! *NOTE* This routine is under active development - call progcld_thompson(p_lay, p_lev, t_lay, q_lay, qs_lay, relhum, tracer, & - xlat, xlon, lsmask, deltaZ*0.001, deltaP, ncnd, i_cldliq, i_cldice, & - i_cldrain, i_cldsnow, i_cldgrpl, nCol, nLev, nLev+1, uni_cld, lmfshal,& - lmfdeep2, & - cldcov, & ! This is an input, but not used... - effrin_cldliq, effrin_cldice, effrin_cldsnow, lwp_ex, iwp_ex, lwp_fc, & - iwp_fc, deltaZc*0.001, dx*0.001, & - cldtot, cldcnv, & ! These are local variables, no intent given.... - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_rwp, cld_rerain,& - cld_swp, cld_resnow) - - else - ! MYNN PBL or convective GF. - call cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & - i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, & - p_lev, p_lay, t_lay, tv_lay, effrin_cldliq, effrin_cldice, & - effrin_cldsnow, tracer, con_g, con_rd, con_ttp, cld_frac, cld_lwp, & - cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain) - endif - ! - ! No SGS clouds - ! - else - if (icloud == 3) then - ! Call progcld_thompson - ! *NOTE* This routine is under active development - call progcld_thompson(p_lay, p_lev, t_lay, q_lay, qs_lay, relhum, tracer, & - xlat, xlon, lsmask, deltaZ*0.001, deltaP, ncnd, i_cldliq, i_cldice, & - i_cldrain, i_cldsnow, i_cldgrpl, nCol, nLev, nLev+1, uni_cld, lmfshal,& - lmfdeep2, & - cldcov, & ! This is an input, but not used... - effrin_cldliq, effrin_cldice, effrin_cldsnow, lwp_ex, iwp_ex, lwp_fc, & - iwp_fc, deltaZc*0.001, dx*0.001, & - cldtot, cldcnv, & ! These are local variables, no intent given... - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_rwp, cld_rerain,& - cld_swp, cld_resnow) - else - ! - if (doGP_convcld) then - call cloud_mp_convective(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, & - relhum, cnv_mixratio, con_ttp, con_g, cnv_cld_lwp, cnv_cld_reliq, & - cnv_cld_iwp, cnv_cld_reice, cnv_cldfrac) - endif - ! - call cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & - i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, & - i_twa, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, relhum, & - con_g, con_rd, con_eps, lmfshal, ltaerosol, imfdeepcnv, imfdeepcnv_gf,& - uni_cld, lmfdeep2, lwp_ex, iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp, & - cld_iwp, cld_swp, cld_rwp) - endif - endif + ! Thomson MP using modified Xu-Randall cloud-fraction (additionally conditioned on RH) + alpha0 = 200. + call cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& + i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, & + relhum, con_g, con_rd, con_eps, alpha0, lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + cld_frac, cld_lwp, cld_iwp, cld_swp, cld_rwp) endif ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from @@ -303,14 +274,26 @@ subroutine GFS_rrtmgp_cloud_mp_finalize() end subroutine GFS_rrtmgp_cloud_mp_finalize ! ###################################################################################### + ! Compute cloud radiative properties for Grell-Freitas convective cloud scheme + ! + ! - The total convective cloud condensate is partitoned by phase, using temperature, into + ! liquid/ice convective cloud mixing-ratios. Compute convective cloud LWP and IWP's. + ! + ! - The liquid and ice cloud effective particle sizes are assigned reference values*. + ! *TODO* Find references, include DOIs, parameterize magic numbers, etc... + ! + ! - The convective cloud-fraction is computed using Xu-Randall (1996). + ! ! ###################################################################################### - subroutine cloud_mp_convective(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, & - cnv_mixratio, con_ttp, con_g, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, & - cnv_cld_reice, cnv_cldfrac) + subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & + qci_conv, con_ttp, con_g, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, & + cld_cnv_frac) ! Inputs integer, intent(in) :: & nCol, & ! Number of horizontal grid points nLev ! Number of vertical layers + real(kind_phys), dimension(:), intent(in) :: & + lsmask ! Land/Sea mask real(kind_phys), intent(in) :: & con_g, & ! Physical constant: gravitational constant con_ttp ! Triple point temperature of water (K) @@ -320,47 +303,161 @@ subroutine cloud_mp_convective(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, p_lay, & ! qs_lay, & ! relhum, & ! - cnv_mixratio ! Convective cloud mixing-ratio (kg/kg) + qci_conv ! ! Outputs real(kind_phys), dimension(:,:),intent(inout) :: & - cnv_cld_lwp, & ! Convective cloud liquid water path - cnv_cld_reliq, & ! Convective cloud liquid effective radius - cnv_cld_iwp, & ! Convective cloud ice water path - cnv_cld_reice, & ! Convective cloud ice effecive radius - cnv_cldfrac ! Convective cloud-fraction (1) + cld_cnv_lwp, & ! Convective cloud liquid water path + cld_cnv_reliq, & ! Convective cloud liquid effective radius + cld_cnv_iwp, & ! Convective cloud ice water path + cld_cnv_reice, & ! Convective cloud ice effecive radius + cld_cnv_frac ! Convective cloud-fraction (1) ! Local integer :: iCol, iLay - real(kind_phys) :: tem1, deltaP, clwc - real(kind_phys), parameter :: alpha0=200 + real(kind_phys) :: tem1, deltaP, clwc, qc, qi + real(kind_phys), parameter :: alpha0=100 - ! Xu-Randall (1996) cloud-fraction. do iLay = 1, nLev do iCol = 1, nCol - cnv_cldfrac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & - qs_lay(iCol,iLay), relhum(iCol,iLay), cnv_mixratio(iCol,iLay), alpha0) + if (qci_conv(iCol,iLay) > 0.) then + ! Partition the convective clouds by phase. + qc = qci_conv(iCol,iLay)*( min(1., max(0., (t_lay(iCol,iLay)-244.)/25.))) + qi = qci_conv(iCol,iLay)*(1. - min(1., max(0., (t_lay(iCol,iLay)-244.)/25.))) + + ! Compute LWP/IWP + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. + tem1 = (1.0e5/con_g) * deltaP + cld_cnv_lwp(iCol,iLay) = max(0., qc * tem1) + cld_cnv_iwp(iCol,iLay) = max(0., qi * tem1) + + ! Particle sizes + if (nint(lsmask(iCol)) == 1) then !land + if(qc > 1.E-8) cld_cnv_reliq(iCol,iLay) = 5.4 + else + !eff radius cloud water (microns), from Miles et al. + if(qc > 1.E-8) cld_cnv_reliq(iCol,iLay) = 9.6 + endif + !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) + if(qi > 1.E-8) cld_cnv_reice(iCol,iLay) = max(173.45 + 2.14*(t_lay(iCol,iLay)-273.15), 20.) + + ! Xu-Randall (1996) cloud-fraction. + cld_cnv_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & + qs_lay(iCol,iLay), relhum(iCol,iLay), qc+qi, alpha0) + endif enddo enddo + end subroutine cloud_mp_GF + + ! ###################################################################################### + ! ###################################################################################### + subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & + qc_mynn, qi_mynn, con_ttp, con_g, cld_mynn_lwp, cld_mynn_reliq, cld_mynn_iwp, & + cld_mynn_reice, cld_mynn_frac) + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev ! Number of vertical layers + real(kind_phys), dimension(:), intent(in) :: & + lsmask ! Land/Sea mask + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_ttp ! Triple point temperature of water (K) + real(kind_phys), dimension(:,:),intent(in) :: & + t_lay, & ! Temperature at layer centers (K) + p_lev, & ! Pressure at layer interfaces (Pa) + p_lay, & ! + qs_lay, & ! + relhum, & ! + qc_mynn, & ! Liquid cloud mixing-ratio (MYNN PBL cloud) + qi_mynn, & ! Ice cloud mixing-ratio (MYNN PBL cloud) + cld_mynn_frac ! Cloud-fraction (MYNN PBL cloud) + ! Outputs + real(kind_phys), dimension(:,:),intent(inout) :: & + cld_mynn_lwp, & ! Convective cloud liquid water path + cld_mynn_reliq, & ! Convective cloud liquid effective radius + cld_mynn_iwp, & ! Convective cloud ice water path + cld_mynn_reice ! Convective cloud ice effecive radius + + ! Local + integer :: iCol, iLay + real(kind_phys) :: tem1, qc, qi, deltaP do iLay = 1, nLev do iCol = 1, nCol - if (cnv_cldfrac(iCol,iLay) > cld_limit_lower) then + if (cld_mynn_frac(iCol,iLay) > cld_limit_lower) then + ! Cloud mixing-ratios + qc = qc_mynn(i,k)*cld_mynn_frac(iCol,iLay) + qi = qi_mynn(i,k)*cld_mynn_frac(iCol,iLay) + + ! LWP/IWP + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. + tem1 = (1.0e5/con_g) * deltaP + cld_mynn_lwp(iCol,iLay) = max(0., qc * tem1) + cld_mynn_iwp(iCol,iLay) = max(0., qi * tem1) + + ! Particle sizes + if (nint(lsmask(iCol)) == 1) then + if(qc > 1.E-8) cld_mynn_reliq(iCol,iLay) = 5.4 + else + ! Cloud water (microns), from Miles et al. + if(qc > 1.E-8) cld_mynn_reliq(iCol,iLay) = 9.6 + endif + ! Cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) + if(qi > 1.E-8) cld_mynn_reice(iCol,iLay) = max(173.45 + 2.14*(t_lay(iCol,iLay)-273.15), 20.) + endif + enddo + enddo + end subroutine cloud_mp_MYNN + + ! ###################################################################################### + ! ###################################################################################### + subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, & + cnv_mixratio, con_ttp, con_g, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & + cld_cnv_reice, cld_cnv_frac) + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev ! Number of vertical layers + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_ttp ! Triple point temperature of water (K) + real(kind_phys), dimension(:,:),intent(in) :: & + t_lay, & ! Temperature at layer centers (K) + p_lev, & ! Pressure at layer interfaces (Pa) + p_lay, & ! + qs_lay, & ! + relhum, & ! + cnv_mixratio ! Convective cloud mixing-ratio (kg/kg) + ! Outputs + real(kind_phys), dimension(:,:),intent(inout) :: & + cld_cnv_lwp, & ! Convective cloud liquid water path + cld_cnv_reliq, & ! Convective cloud liquid effective radius + cld_cnv_iwp, & ! Convective cloud ice water path + cld_cnv_reice, & ! Convective cloud ice effecive radius + cld_cnv_frac ! Convective cloud-fraction (1) + ! Local + integer :: iCol, iLay + real(kind_phys) :: tem1, deltaP, clwc + real(kind_phys), parameter :: alpha0=200 + + do iLay = 1, nLev + do iCol = 1, nCol + if (cnv_mixratio(iCol,iLay) > 0._kind_phys) then tem1 = min(1.0, max(0.0, (con_ttp-t_lay(iCol,iLay))*0.05)) deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. clwc = max(0.0, cnv_mixratio(iCol,iLay)) * con_g * deltaP - cnv_cld_iwp(iCol,iLay) = clwc * tem1 - cnv_cld_lwp(iCol,iLay) = clwc - cnv_cld_iwp(iCol,iLay) - cnv_cld_reliq(iCol,iLay) = reliq_def - cnv_cld_reice(iCol,iLay) = reice_def - else - cnv_cld_iwp(iCol,iLay) = 0._kind_phys - cnv_cld_lwp(iCol,iLay) = 0._kind_phys - cnv_cld_reliq(iCol,iLay) = 0._kind_phys - cnv_cld_reice(iCol,iLay) = 0._kind_phys + cld_cnv_iwp(iCol,iLay) = clwc * tem1 + cld_cnv_lwp(iCol,iLay) = clwc - cld_cnv_iwp(iCol,iLay) + cld_cnv_reliq(iCol,iLay) = reliq_def + cld_cnv_reice(iCol,iLay) = reice_def + + ! Xu-Randall (1996) cloud-fraction. + cld_cnv_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & + qs_lay(iCol,iLay), relhum(iCol,iLay), cnv_mixratio(iCol,iLay), alpha0) endif enddo enddo - end subroutine cloud_mp_convective + end subroutine cloud_mp_SAMF ! ###################################################################################### ! ###################################################################################### @@ -419,10 +516,9 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai cld_rerain ! Cloud rain effective radius ! Local variables - real(kind_phys) :: tem1,tem2,tem3,pfac + real(kind_phys) :: tem1,tem2,tem3,pfac,deltaP real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate integer :: iCol,iLay,l,ncndl - real(kind_phys), dimension(nCol,nLev) :: deltaP ! Cloud condensate cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water @@ -434,12 +530,12 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai endif ! Cloud water path (g/m2) - deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. do iLay = 1, nLev do iCol = 1, nCol ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) if (cld_frac(iCol,iLay) > cld_limit_lower) then - tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. + tem1 = (1.0e5/con_g) * deltaP cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) if (ncnd > 2) then @@ -472,7 +568,8 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai ! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. tem2 = t_lay(iCol,iLay) - con_ttp if (cld_iwp(iCol,iLay) > 0.0) then - tem3 = (con_g/con_rd ) * cld_iwp(iCol,iLay) * (0.01*p_lay(iCol,iLay)) / (deltaP(iCol,iLay)*tv_lay(iCol,iLay)) + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. + tem3 = (con_g/con_rd ) * cld_iwp(iCol,iLay) * (0.01*p_lay(iCol,iLay)) / (deltaP*tv_lay(iCol,iLay)) if (tem2 < -50.0) then cld_reice(iCol,iLay) = (1250.0/9.917) * tem3 ** 0.109 elseif (tem2 < -40.0) then @@ -492,11 +589,9 @@ end subroutine cloud_mp_uni ! ###################################################################################### ! ###################################################################################### subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& - i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, p_lev, & - p_lay, tv_lay, t_lay, tracer, & - qs_lay, q_lay, relhum, con_g, con_rd, con_eps, lmfshal, ltaerosol, imfdeepcnv, & - imfdeepcnv_gf, uni_cld, lmfdeep2, & - lwp_ex, iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp, cld_iwp, cld_swp, cld_rwp) + i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, relhum, & + con_g, con_rd, con_eps, alpha0, lwp_ex, iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp,& + cld_iwp, cld_swp, cld_rwp) implicit none ! Inputs @@ -509,23 +604,12 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c i_cldice, & ! cloud ice amount. i_cldrain, & ! cloud rain amount. i_cldsnow, & ! cloud snow amount. - i_cldgrpl, & ! cloud groupel amount. - i_cldtot, & ! cloud total amount. - i_cldliq_nc, & ! cloud liquid number concentration. - i_cldice_nc, & ! cloud ice number concentration. - i_twa, & ! water friendly aerosol. - imfdeepcnv, & ! Choice of mass-flux deep convection scheme - imfdeepcnv_gf ! Flag for Grell-Freitas deep convection scheme - logical, intent(in) :: & - uni_cld, & ! Flag for unified cloud scheme - lmfshal, & ! Flag for mass-flux shallow convection scheme used by Xu-Randall - ltaerosol, & ! Flag for aerosol option - lmfdeep2 ! Flag for mass flux deep convection + i_cldgrpl ! cloud groupel amount. real(kind_phys), intent(in) :: & con_g, & ! Physical constant: gravitational constant con_rd, & ! Physical constant: gas-constant for dry air - con_eps ! Physical constant: gas constant air / gas constant H2O - + con_eps, & ! Physical constant: gas constant air / gas constant H2O + alpha0 ! real(kind_phys), dimension(:,:), intent(in) :: & tv_lay, & ! Virtual temperature (K) t_lay, & ! Temperature (K) @@ -552,10 +636,9 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c cld_rwp ! Cloud rain water path ! Local variables - real(kind_phys) :: alpha0, pfac, tem1, cld_mr + real(kind_phys) :: pfac, tem1, cld_mr, deltaP real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate integer :: iCol,iLay,l - real(kind_phys), dimension(nCol,nLev) :: deltaP ! Cloud condensate cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water @@ -565,47 +648,31 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c tracer(1:nCol,1:nLev,i_cldgrpl) ! Cloud water path (g/m2) - deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. do iLay = 1, nLev do iCol = 1, nCol ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) - tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. + tem1 = (1.0e5/con_g) * deltaP cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) enddo enddo - - ! Compute cloud-fraction. Only if not pre-computed - if(.not. uni_cld) then - ! Cloud-fraction - if(.not. lmfshal) then - alpha0 = 2000. ! Default (from GATE simulations) - else - if (lmfdeep2) then - alpha0 = 200 - else - alpha0 = 100 - endif - endif - ! Xu-Randall (1996) cloud-fraction. Conditioned on relative-humidity - do iLay = 1, nLev - do iCol = 1, nCol - if (relhum(iCol,iLay) > 0.99) then - cld_frac(iCol,iLay) = 1._kind_phys - else - cld_mr = cld_condensate(iCol,iLay,1) + cld_condensate(iCol,iLay,2) + & - cld_condensate(iCol,iLay,4) - cld_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & - qs_lay(iCol,iLay), relhum(iCol,iLay), cld_mr, alpha0) - endif - enddo + ! Xu-Randall (1996) cloud-fraction. **Additionally, Conditioned on relative-humidity** + do iLay = 1, nLev + do iCol = 1, nCol + if (relhum(iCol,iLay) > 0.99) then + cld_frac(iCol,iLay) = 1._kind_phys + else + cld_mr = cld_condensate(iCol,iLay,1) + cld_condensate(iCol,iLay,2) + & + cld_condensate(iCol,iLay,4) + cld_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & + qs_lay(iCol,iLay), relhum(iCol,iLay), cld_mr, alpha0) + endif enddo - else - cld_frac = tracer(:,:,i_cldtot) - endif + enddo ! Sum the liquid water and ice paths that come from explicit micro ! What portion of water and ice contents is associated with the partly cloudy boxes? diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index 10d6d1c12..0372e311a 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -154,41 +154,6 @@ dimensions = () type = integer intent = in -[imp_physics_zhao_carr] - standard_name = identifier_for_zhao_carr_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_zhao_carr_pdf] - standard_name = identifier_for_zhao_carr_pdf_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme with PDF clouds - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_mg] - standard_name = identifier_for_morrison_gettelman_microphysics_scheme - long_name = choice of Morrison-Gettelman microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_wsm6] - standard_name = identifier_for_wsm6_microphysics_scheme - long_name = choice of WSM6 microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_fer_hires] - standard_name = identifier_for_fer_hires_microphysics_scheme - long_name = choice of Ferrier-Aligo microphysics scheme - units = flag - dimensions = () - type = integer - intent = in [do_mynnedmf] standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme long_name = flag to activate MYNN-EDMF @@ -238,16 +203,16 @@ dimensions = () type = integer intent = in -[lgfdlmprad] - standard_name = flag_for_GFDL_microphysics_radiation_interaction - long_name = flag for GFDL microphysics-radiation interaction +[imfdeepcnv_samf] + standard_name = identifer_for_scale_aware_mass_flux_deep_convection + long_name = flag for SAMF deep convection scheme units = flag dimensions = () - type = logical + type = integer intent = in -[doGP_convcld] - standard_name = flag_to_include_convective_cloud_in_RRTMGP - long_name = logical flag to control convective cloud in RRTMGP +[lgfdlmprad] + standard_name = flag_for_GFDL_microphysics_radiation_interaction + long_name = flag for GFDL microphysics-radiation interaction units = flag dimensions = () type = logical @@ -388,7 +353,7 @@ type = real kind = kind_phys intent = in -[cnv_cldfrac] +[cld_cnv_frac] standard_name = convective_cloud_fraction_for_RRTMGP long_name = layer convective cloud fraction units = frac @@ -428,6 +393,30 @@ type = real kind = kind_phys intent = in +[qc_mynn] + standard_name = subgrid_scale_cloud_liquid_water_mixing_ratio + long_name = subgrid cloud water mixing ratio from PBL scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qi_mynn] + standard_name = subgrid_scale_cloud_ice_mixing_ratio + long_name = subgrid cloud ice mixing ratio from PBL scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_mynn_frac] + standard_name = subgrid_scale_cloud_area_fraction_in_atmosphere_layer + long_name = subgrid cloud fraction from PBL scheme + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -554,7 +543,7 @@ type = real kind = kind_phys intent = inout -[cnv_cld_lwp] +[cld_cnv_lwp] standard_name = convective_cloud_liquid_water_path long_name = layer convective cloud liquid water path units = g m-2 @@ -562,7 +551,7 @@ type = real kind = kind_phys intent = inout -[cnv_cld_iwp] +[cld_cnv_iwp] standard_name = convective_cloud_ice_water_path long_name = layer convective cloud ice water path units = g m-2 @@ -570,19 +559,51 @@ type = real kind = kind_phys intent = inout -[cnv_cld_reliq] +[cld_cnv_reliq] standard_name = mean_effective_radius_for_liquid_convective_cloud long_name = mean effective radius for liquid convective cloud units = um - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout -[cnv_cld_reice] +[cld_cnv_reice] standard_name = mean_effective_radius_for_ice_convective_cloud long_name = mean effective radius for ice convective cloud units = um - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_mynn_lwp] + standard_name = MYNN_SGS_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_mynn_iwp] + standard_name = MYNN_SGS_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_mynn_reliq] + standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud + long_name = mean effective radius for liquid MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_mynn_reice] + standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud + long_name = mean effective radius for ice MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 index 3a30d2f32..aacc94662 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -23,8 +23,8 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, julian, lat, p_lev, p_lay, tv_lay, deltaZc, con_pi, con_g, con_rd, con_epsq, & dcorr_con, idcor, iovr, iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & idcor_hogan, idcor_oreopoulos, cld_frac, cnv_cldfrac, iovr_convcld, top_at_1, & - doGP_convcld, de_lgth, cloud_overlap_param, cnv_cloud_overlap_param, & - precip_overlap_param, errmsg, errflg) + imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, de_lgth, cloud_overlap_param, & + cnv_cloud_overlap_param, precip_overlap_param, errmsg, errflg) implicit none ! Inputs @@ -43,7 +43,9 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, idcor_oreopoulos ! Flag for decorrelation-length. (10.5194/acp-12-9097-2012) logical, intent(in) :: & top_at_1, & ! Vertical ordering flag - doGP_convcld, & ! Compute overlap parameter for convective cloud? + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! doSWrad, & ! Call SW radiation? doLWrad ! Call LW radiation real(kind_phys), intent(in) :: & @@ -111,7 +113,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! ! Convective cloud overlap parameter ! - if (doGP_convcld) then + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then if (iovr_convcld == iovr_dcorr .or. iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001, de_lgth, cnv_cldfrac, cnv_cloud_overlap_param) else diff --git a/physics/GFS_rrtmgp_cloud_overlap.meta b/physics/GFS_rrtmgp_cloud_overlap.meta index eb16f9159..3204d2acb 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.meta +++ b/physics/GFS_rrtmgp_cloud_overlap.meta @@ -216,12 +216,26 @@ dimensions = () type = logical intent = in -[doGP_convcld] - standard_name = flag_to_include_convective_cloud_in_RRTMGP - long_name = logical flag to control convective cloud in RRTMGP +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme units = flag dimensions = () - type = logical + 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 [de_lgth] standard_name = cloud_decorrelation_length diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 4dfcc1e27..6d6fb93cc 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -383,11 +383,12 @@ end subroutine rrtmgp_lw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, doGP_convcld, nCol, nLev, & - nbndsGPlw , p_lay, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, & - cld_resnow, cld_rwp, cld_rerain, precip_frac, cnv_cld_lwp, cnv_cld_reliq, & - cnv_cld_iwp, cnv_cld_reice, lon, lat, cldtaulw, lw_optical_props_cloudsByBand, & - lw_optical_props_cnvcloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) + doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, imfdeepcnv, imfdeepcnv_gf, & + imfdeepcnv_samf, nCol, nLev, nbndsGPlw , p_lay, cld_frac, cld_lwp, cld_reliq, & + cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & + cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice, lon, lat, cldtaulw, & + lw_optical_props_cloudsByBand, lw_optical_props_cnvcloudsByBand, & + lw_optical_props_precipByBand, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -396,7 +397,9 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? doGP_lwscat, & ! Include scattering in LW cloud-optics? - doGP_convcld ! + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf ! integer, intent(in) :: & nbndsGPlw, & ! nCol, & ! Number of horizontal gridpoints @@ -475,7 +478,7 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties ! in each band ! ii) Convective cloud-optics - if (doGP_convcld) then + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then call check_error_msg('rrtmgp_lw_cnvcloud_optics_run - convective cloud',lw_cloud_props%cloud_optics(& cnv_cld_lwp, & ! IN - Convective cloud liquid water path (g/m2) cnv_cld_iwp, & ! IN - Convective cloud ice water path (g/m2) diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index fcb19fb41..dd129f10c 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -141,12 +141,26 @@ dimensions = () type = logical intent = in -[doGP_convcld] - standard_name = flag_to_include_convective_cloud_in_RRTMGP - long_name = logical flag to control convective cloud in RRTMGP +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme units = flag dimensions = () - type = logical + 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 [ncol] standard_name = horizontal_loop_extent @@ -262,7 +276,7 @@ standard_name = mean_effective_radius_for_liquid_convective_cloud long_name = mean effective radius for liquid convective cloud units = um - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -270,7 +284,7 @@ standard_name = mean_effective_radius_for_ice_convective_cloud long_name = mean effective radius for ice convective cloud units = um - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 index 131cfd168..95d2f9099 100644 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ b/physics/rrtmgp_lw_cloud_sampling.F90 @@ -21,15 +21,17 @@ module rrtmgp_lw_cloud_sampling subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iovr_convcld,& iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, & cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, cnv_cldfrac, & - cnv_cloud_overlap_param, doGP_convcld, lw_optical_props_cloudsByBand, & - lw_optical_props_cnvcloudsByBand, lw_optical_props_precipByBand, & - lw_optical_props_clouds, lw_optical_props_cnvclouds, lw_optical_props_precip, & - errmsg, errflg) + cnv_cloud_overlap_param, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, & + lw_optical_props_cloudsByBand, lw_optical_props_cnvcloudsByBand, & + lw_optical_props_precipByBand, lw_optical_props_clouds, lw_optical_props_cnvclouds, & + lw_optical_props_precip, errmsg, errflg) ! Inputs logical, intent(in) :: & doLWrad, & ! Logical flag for shortwave radiation call - doGP_convcld + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf ! integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical layers @@ -158,7 +160,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iov ! Convective cloud ... ! (Use same RNGs as was used by the clouds.) ! #################################################################################### - if (doGP_convcld) then + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then lw_optical_props_cnvclouds%band2gpt = lw_gas_props%get_band_lims_gpoint() lw_optical_props_cnvclouds%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() do iBand=1,lw_gas_props%get_nband() diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta index c2224cd78..5f4fdc37c 100644 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ b/physics/rrtmgp_lw_cloud_sampling.meta @@ -14,12 +14,26 @@ dimensions = () type = logical intent = in -[doGP_convcld] - standard_name = flag_to_include_convective_cloud_in_RRTMGP - long_name = logical flag to control convective cloud in RRTMGP +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme units = flag dimensions = () - type = logical + 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 [iovr_convcld] standard_name = flag_for_convective_cloud_overlap_method_for_radiation diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index c4272b982..717568bdc 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -26,11 +26,11 @@ end subroutine rrtmgp_lw_rte_init !! \htmlinclude rrtmgp_lw_rte_run.html !! subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & - nLev, top_at_1, doGP_convcld, sfc_emiss_byband, sources, lw_optical_props_clrsky, & - lw_optical_props_clouds, lw_optical_props_precip, lw_optical_props_cnvclouds, & - lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, fluxlwDOWN_allsky, & - fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwUP_radtime, & - fluxlwDOWN_radtime, errmsg, errflg) + nLev, top_at_1, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, sfc_emiss_byband, & + sources, lw_optical_props_clrsky, lw_optical_props_clouds, lw_optical_props_precip, & + lw_optical_props_cnvclouds, lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky,& + fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, & + fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -38,7 +38,9 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, doLWrad, & ! Logical flag for longwave radiation call doLWclrsky, & ! Compute clear-sky fluxes for clear-sky heating-rate? use_LW_jacobian, & ! Compute Jacobian of LW to update radiative fluxes between radiation calls? - doGP_convcld, & ! Flag to include convective cloud + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! doGP_lwscat ! Include scattering in LW cloud-optics? integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints @@ -128,7 +130,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, ! ! Include convective cloud? - if (doGP_convcld) then + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_cnvclouds%increment(lw_optical_props_clrsky)) endif diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 194ef725d..517900773 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -36,12 +36,26 @@ dimensions = () type = logical intent = in -[doGP_convcld] - standard_name = flag_to_include_convective_cloud_in_RRTMGP - long_name = logical flag to control convective cloud in RRTMGP +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme units = flag dimensions = () - type = logical + 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 [ncol] standard_name = horizontal_loop_extent diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 01db38374..6b5b6f308 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -395,11 +395,12 @@ end subroutine rrtmgp_sw_cloud_optics_init !! \htmlinclude rrtmgp_sw_cloud_optics.html !! subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_convcld, nCol, nLev, nDay, nbndsGPsw, & - idxday, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, & - cld_rwp, cld_rerain, precip_frac, cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, & - cnv_cld_reice, sw_optical_props_cloudsByBand, sw_optical_props_cnvcloudsByBand, & - sw_optical_props_precipByBand, cldtausw, errmsg, errflg) + doGP_cldoptics_PADE, doGP_cldoptics_LUT, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, & + nCol, nLev, nDay, nbndsGPsw, idxday, cld_frac, cld_lwp, cld_reliq, cld_iwp, & + cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, cnv_cld_lwp, & + cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice, sw_optical_props_cloudsByBand, & + sw_optical_props_cnvcloudsByBand, sw_optical_props_precipByBand, cldtausw, & + errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -407,7 +408,9 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw doG_cldoptics, & ! Use legacy RRTMG cloud-optics? doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? - doGP_convcld ! + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf ! integer, intent(in) :: & nbndsGPsw, & ! Number of shortwave bands nCol, & ! Number of horizontal gridpoints @@ -489,7 +492,7 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, ! in each band (tau,ssa,g) ! ii) Convective cloud-optics - if (doGP_convcld) then + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then call check_error_msg('rrtmgp_sw_cloud_optics_run - convective clouds',sw_cloud_props%cloud_optics(& cnv_cld_lwp(idxday(1:nday),:), & ! IN - Convective cloud liquid water path cnv_cld_iwp(idxday(1:nday),:), & ! IN - Convective cloud ice water path diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta index 913979f60..b53481d21 100644 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ b/physics/rrtmgp_sw_cloud_optics.meta @@ -147,12 +147,26 @@ dimensions = () type = logical intent = in -[doGP_convcld] - standard_name = flag_to_include_convective_cloud_in_RRTMGP - long_name = logical flag to control convective cloud in RRTMGP +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme units = flag dimensions = () - type = logical + 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 [cld_frac] standard_name = total_cloud_fraction @@ -254,7 +268,7 @@ standard_name = mean_effective_radius_for_liquid_convective_cloud long_name = mean effective radius for liquid convective cloud units = um - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in @@ -262,7 +276,7 @@ standard_name = mean_effective_radius_for_ice_convective_cloud long_name = mean effective radius for ice convective cloud units = um - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 index 30a4cdf32..10ac6b564 100644 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -21,14 +21,16 @@ module rrtmgp_sw_cloud_sampling subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, & iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, & isubc_sw,icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param,& - doGP_convcld, cnv_cloud_overlap_param, cnv_cldfrac,sw_optical_props_cnvcloudsByBand, & - sw_optical_props_cloudsByBand, sw_optical_props_precipByBand, & - sw_optical_props_clouds, sw_optical_props_cnvclouds, sw_optical_props_precip, & - errmsg, errflg) + imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, cnv_cloud_overlap_param, cnv_cldfrac, & + sw_optical_props_cnvcloudsByBand, sw_optical_props_cloudsByBand, & + sw_optical_props_precipByBand, sw_optical_props_clouds, sw_optical_props_cnvclouds, & + sw_optical_props_precip, errmsg, errflg) ! Inputs logical, intent(in) :: & - doGP_convcld, & ! + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! doSWrad ! Logical flag for shortwave radiation call integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints @@ -160,7 +162,7 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, ! Convective cloud... ! (Use same RNGs as was used by the clouds.) ! ################################################################################# - if (doGP_convcld) then + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then ! Allocate space RRTMGP DDTs [nday,nLev,nGpt] call check_error_msg('rrtmgp_sw_cnvcloud_sampling_run', & diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta index c5b3bce10..72766bfbf 100644 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ b/physics/rrtmgp_sw_cloud_sampling.meta @@ -14,12 +14,26 @@ dimensions = () type = logical intent = in -[doGP_convcld] - standard_name = flag_to_include_convective_cloud_in_RRTMGP - long_name = logical flag to control convective cloud in RRTMGP +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme units = flag dimensions = () - type = logical + 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 [iovr_convcld] standard_name = flag_for_convective_cloud_overlap_method_for_radiation diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index 0c2ea5288..c7a065019 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -25,16 +25,18 @@ end subroutine rrtmgp_sw_rte_init !! \htmlinclude rrtmgp_sw_rte.html !! subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay,& - t_lay, top_at_1, doGP_convcld, iSFC, sfc_alb_nir_dir, sfc_alb_nir_dif, & - sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clrsky, & - sw_optical_props_clouds, sw_optical_props_precip, sw_optical_props_cnvclouds, & - sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, & - fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) + t_lay, top_at_1, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, iSFC, sfc_alb_nir_dir, & + sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, & + sw_optical_props_clrsky, sw_optical_props_clouds, sw_optical_props_precip, & + sw_optical_props_cnvclouds, sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, & + fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) ! Inputs logical, intent(in) :: & top_at_1, & ! Vertical ordering flag - doGP_convcld, & ! Flag to include convective cloud + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! doSWrad, & ! Flag to calculate SW irradiances doSWclrsky ! Compute clear-sky fluxes? integer, intent(in) :: & @@ -152,7 +154,7 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz ! ! Include convective cloud? - if (doGP_convcld) then + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_cnvclouds%increment(sw_optical_props_clrsky)) endif diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index bf1b43179..aa8a8d4ec 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -22,12 +22,26 @@ dimensions = () type = logical intent = in -[doGP_convcld] - standard_name = flag_to_include_convective_cloud_in_RRTMGP - long_name = logical flag to control convective cloud in RRTMGP +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme units = flag dimensions = () - type = logical + 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 [ncol] standard_name = horizontal_loop_extent From 63fb052a7631cb67b92f6de2eda809b049375cd4 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 4 Mar 2022 23:03:49 +0000 Subject: [PATCH 084/217] Added new cloud-optics for MYNN-EDMF clouds --- physics/GFS_rrtmgp_cloud_mp.F90 | 12 ++++++ physics/GFS_rrtmgp_cloud_mp.meta | 16 ++++---- physics/GFS_rrtmgp_cloud_overlap.F90 | 12 +++--- physics/GFS_rrtmgp_cloud_overlap.meta | 2 +- physics/rrtmgp_lw_cloud_optics.F90 | 47 ++++++++++++---------- physics/rrtmgp_lw_cloud_optics.meta | 54 ++++++++++++++++++++++++-- physics/rrtmgp_lw_cloud_sampling.F90 | 18 ++++----- physics/rrtmgp_lw_cloud_sampling.meta | 2 +- physics/rrtmgp_lw_rte.F90 | 6 +-- physics/rrtmgp_sw_cloud_optics.F90 | 56 +++++++++++++++------------ physics/rrtmgp_sw_cloud_optics.meta | 54 ++++++++++++++++++++++++-- physics/rrtmgp_sw_cloud_sampling.F90 | 16 ++++---- physics/rrtmgp_sw_cloud_sampling.meta | 2 +- physics/rrtmgp_sw_rte.F90 | 6 +-- 14 files changed, 211 insertions(+), 92 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 6ae511326..1108818d9 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -262,6 +262,18 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic where(cld_reliq .gt. radliq_upr) cld_reliq = radliq_upr where(cld_reice .lt. radice_lwr) cld_reice = radice_lwr where(cld_reice .gt. radice_upr) cld_reice = radice_upr + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then + where(cld_cnv_reliq .lt. radliq_lwr) cld_cnv_reliq = radliq_lwr + where(cld_cnv_reliq .gt. radliq_upr) cld_cnv_reliq = radliq_upr + where(cld_cnv_reice .lt. radice_lwr) cld_cnv_reice = radice_lwr + where(cld_cnv_reice .gt. radice_upr) cld_cnv_reice = radice_upr + endif + if (do_mynnedmf) then + where(cld_mynn_reliq .lt. radliq_lwr) cld_mynn_reliq = radliq_lwr + where(cld_mynn_reliq .gt. radliq_upr) cld_mynn_reliq = radliq_upr + where(cld_mynn_reice .lt. radice_lwr) cld_mynn_reice = radice_lwr + where(cld_mynn_reice .gt. radice_upr) cld_mynn_reice = radice_upr + endif endif precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index 0372e311a..39706f0e1 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -409,14 +409,6 @@ type = real kind = kind_phys intent = in -[cld_mynn_frac] - standard_name = subgrid_scale_cloud_area_fraction_in_atmosphere_layer - long_name = subgrid cloud fraction from PBL scheme - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -575,6 +567,14 @@ type = real kind = kind_phys intent = inout +[cld_mynn_frac] + standard_name = subgrid_scale_cloud_area_fraction_in_atmosphere_layer + long_name = subgrid cloud fraction from PBL scheme + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [cld_mynn_lwp] standard_name = MYNN_SGS_cloud_liquid_water_path long_name = layer convective cloud liquid water path diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 index aacc94662..7f092dba3 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -22,7 +22,7 @@ end subroutine GFS_rrtmgp_cloud_overlap_init subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, & julian, lat, p_lev, p_lay, tv_lay, deltaZc, con_pi, con_g, con_rd, con_epsq, & dcorr_con, idcor, iovr, iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & - idcor_hogan, idcor_oreopoulos, cld_frac, cnv_cldfrac, iovr_convcld, top_at_1, & + idcor_hogan, idcor_oreopoulos, cld_frac, cld_cnv_frac, iovr_convcld, top_at_1, & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, de_lgth, cloud_overlap_param, & cnv_cloud_overlap_param, precip_overlap_param, errmsg, errflg) implicit none @@ -32,6 +32,9 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers yearlen, & ! Length of current year (365/366) WTF? + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! iovr, & ! Choice of cloud-overlap method iovr_convcld, & ! Choice of convective cloud-overlap method iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method @@ -43,9 +46,6 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, idcor_oreopoulos ! Flag for decorrelation-length. (10.5194/acp-12-9097-2012) logical, intent(in) :: & top_at_1, & ! Vertical ordering flag - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! doSWrad, & ! Call SW radiation? doLWrad ! Call LW radiation real(kind_phys), intent(in) :: & @@ -61,7 +61,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, tv_lay, & ! Virtual temperature (K) p_lay, & ! Pressure at model-layers (Pa) cld_frac, & ! Total cloud fraction - cnv_cldfrac ! Convective cloud-fraction + cld_cnv_frac ! Convective cloud-fraction real(kind_phys), dimension(:,:), intent(in) :: & p_lev, & ! Pressure at model-level interfaces (Pa) deltaZc ! Layer thickness (from layer-centers)(m) @@ -115,7 +115,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then if (iovr_convcld == iovr_dcorr .or. iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then - call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001, de_lgth, cnv_cldfrac, cnv_cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) else de_lgth(:) = 0. cnv_cloud_overlap_param(:,:) = 0. diff --git a/physics/GFS_rrtmgp_cloud_overlap.meta b/physics/GFS_rrtmgp_cloud_overlap.meta index 3204d2acb..f7d12bed5 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.meta +++ b/physics/GFS_rrtmgp_cloud_overlap.meta @@ -201,7 +201,7 @@ type = real kind = kind_phys intent = in -[cnv_cldfrac] +[cld_cnv_frac] standard_name = convective_cloud_fraction_for_RRTMGP long_name = layer convective cloud fraction units = frac diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 6d6fb93cc..3068ff1b5 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -383,12 +383,13 @@ end subroutine rrtmgp_lw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, imfdeepcnv, imfdeepcnv_gf, & - imfdeepcnv_samf, nCol, nLev, nbndsGPlw , p_lay, cld_frac, cld_lwp, cld_reliq, & - cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & - cnv_cld_lwp, cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice, lon, lat, cldtaulw, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, do_mynnedmf, imfdeepcnv, & + imfdeepcnv_gf, imfdeepcnv_samf, nCol, nLev, nbndsGPlw , p_lay, cld_frac, cld_lwp, & + cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & + precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_mynn_lwp,& + cld_mynn_reliq, cld_mynn_iwp, cld_mynn_reice, lon, lat, cldtaulw, & lw_optical_props_cloudsByBand, lw_optical_props_cnvcloudsByBand, & - lw_optical_props_precipByBand, errmsg, errflg) + lw_optical_props_MYNNcloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -397,15 +398,16 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? doGP_lwscat, & ! Include scattering in LW cloud-optics? - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf ! + do_mynnedmf ! integer, intent(in) :: & nbndsGPlw, & ! nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels icliq_lw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) - icice_lw ! Choice of treatment of ice cloud optical properties (RRTMG legacy) + icice_lw, & ! Choice of treatment of ice cloud optical properties (RRTMG legacy) + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf ! real(kind_phys), dimension(nCol), intent(in) :: & lon, & ! Longitude lat ! Latitude @@ -421,10 +423,14 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw cld_rwp, & ! Cloud rain water path cld_rerain, & ! Cloud rain effective radius precip_frac, & ! Precipitation fraction by layer. - cnv_cld_lwp, & ! Water path for convective liquid cloud-particles (microns) - cnv_cld_reliq, & ! Effective radius for convective liquid cloud-particles (microns) - cnv_cld_iwp, & ! Water path for convective ice cloud-particles (microns) - cnv_cld_reice ! Effective radius for convective ice cloud-particles (microns) + cld_cnv_lwp, & ! Water path for convective liquid cloud-particles (microns) + cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) + cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) + cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) + cld_mynn_lwp, & + cld_mynn_reliq, & + cld_mynn_iwp, & + cld_mynn_reice ! Outputs character(len=*), intent(out) :: & @@ -432,9 +438,10 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw integer, intent(out) :: & errflg ! CCPP error flag type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) - lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) - lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) + lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) + lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) + lw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (MYNN-PBL cloud) + lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) real(kind_phys), dimension(ncol,nLev), intent(inout) :: & cldtaulw ! Approx 10.mu band layer cloud optical depth @@ -480,10 +487,10 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw ! ii) Convective cloud-optics if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then call check_error_msg('rrtmgp_lw_cnvcloud_optics_run - convective cloud',lw_cloud_props%cloud_optics(& - cnv_cld_lwp, & ! IN - Convective cloud liquid water path (g/m2) - cnv_cld_iwp, & ! IN - Convective cloud ice water path (g/m2) - cnv_cld_reliq, & ! IN - Convective cloud liquid effective radius (microns) - cnv_cld_reice, & ! IN - Convective cloud ice effective radius (microns) + cld_cnv_lwp, & ! IN - Convective cloud liquid water path (g/m2) + cld_cnv_iwp, & ! IN - Convective cloud ice water path (g/m2) + cld_cnv_reliq, & ! IN - Convective cloud liquid effective radius (microns) + cld_cnv_reice, & ! IN - Convective cloud ice effective radius (microns) lw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties ! in each band endif diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index dd129f10c..d1486f439 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -141,6 +141,13 @@ dimensions = () type = logical 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 [imfdeepcnv] standard_name = control_for_deep_convection_scheme long_name = flag for mass-flux deep convection scheme @@ -256,7 +263,7 @@ type = real kind = kind_phys intent = in -[cnv_cld_lwp] +[cld_cnv_lwp] standard_name = convective_cloud_liquid_water_path long_name = layer convective cloud liquid water path units = g m-2 @@ -264,7 +271,7 @@ type = real kind = kind_phys intent = in -[cnv_cld_iwp] +[cld_cnv_iwp] standard_name = convective_cloud_ice_water_path long_name = layer convective cloud ice water path units = g m-2 @@ -272,7 +279,7 @@ type = real kind = kind_phys intent = in -[cnv_cld_reliq] +[cld_cnv_reliq] standard_name = mean_effective_radius_for_liquid_convective_cloud long_name = mean effective radius for liquid convective cloud units = um @@ -280,7 +287,7 @@ type = real kind = kind_phys intent = in -[cnv_cld_reice] +[cld_cnv_reice] standard_name = mean_effective_radius_for_ice_convective_cloud long_name = mean effective radius for ice convective cloud units = um @@ -288,6 +295,38 @@ type = real kind = kind_phys intent = in +[cld_mynn_lwp] + standard_name = MYNN_SGS_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_mynn_iwp] + standard_name = MYNN_SGS_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_mynn_reliq] + standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud + long_name = mean effective radius for liquid MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_mynn_reice] + standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud + long_name = mean effective radius for ice MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [p_lay] standard_name = air_pressure_at_layer_for_RRTMGP long_name = air pressure layer @@ -341,6 +380,13 @@ dimensions = () type = ty_optical_props_2str intent = inout +[lw_optical_props_MYNNcloudsByBand] + standard_name = longwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout [lw_optical_props_precipByBand] standard_name = longwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 index 95d2f9099..fad6c9b61 100644 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ b/physics/rrtmgp_lw_cloud_sampling.F90 @@ -20,7 +20,7 @@ module rrtmgp_lw_cloud_sampling !! subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iovr_convcld,& iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, & - cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, cnv_cldfrac, & + cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, cld_cnv_frac, & cnv_cloud_overlap_param, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, & lw_optical_props_cloudsByBand, lw_optical_props_cnvcloudsByBand, & lw_optical_props_precipByBand, lw_optical_props_clouds, lw_optical_props_cnvclouds, & @@ -28,13 +28,13 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iov ! Inputs logical, intent(in) :: & - doLWrad, & ! Logical flag for shortwave radiation call - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf ! + doLWrad ! Logical flag for shortwave radiation call integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical layers + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! iovr, & ! Choice of cloud-overlap method iovr_convcld, & ! Choice of convective cloud-overlap iovr_max, & ! Flag for maximum cloud overlap method @@ -51,7 +51,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iov ! random numbers. when isubc_lw /=2, it will not be used. real(kind_phys), dimension(ncol,nLev),intent(in) :: & cld_frac, & ! Total cloud fraction by layer - cnv_cldfrac, & ! Convective cloud fraction by layer + cld_cnv_frac, & ! Convective cloud fraction by layer precip_frac ! Precipitation fraction by layer real(kind_phys), dimension(ncol,nLev), intent(in) :: & cloud_overlap_param, & ! Cloud overlap parameter @@ -171,17 +171,17 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iov ! Convective cloud overlap ! Maximum-random, random or maximum. if (iovr_convcld == iovr_maxrand .or. iovr_convcld == iovr_rand .or. iovr_convcld == iovr_max) then - call sampled_mask(rng3D, cnv_cldfrac, maskMCICA) + call sampled_mask(rng3D, cld_cnv_frac, maskMCICA) endif ! Exponential decorrelation length overlap if (iovr_convcld == iovr_dcorr) then - call sampled_mask(rng3D, cnv_cldfrac, maskMCICA, & + call sampled_mask(rng3D, cld_cnv_frac, maskMCICA, & overlap_param = cnv_cloud_overlap_param(:,1:nLev-1), & randoms2 = rng3D2) endif ! Exponential or Exponential-random if (iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then - call sampled_mask(rng3D, cnv_cldfrac, maskMCICA, & + call sampled_mask(rng3D, cld_cnv_frac, maskMCICA, & overlap_param = cnv_cloud_overlap_param(:,1:nLev-1)) endif diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta index 5f4fdc37c..c1ae9d139 100644 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ b/physics/rrtmgp_lw_cloud_sampling.meta @@ -127,7 +127,7 @@ type = real kind = kind_phys intent = in -[cnv_cldfrac] +[cld_cnv_frac] standard_name = convective_cloud_fraction_for_RRTMGP long_name = layer convective cloud fraction units = frac diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index 717568bdc..b500e1691 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -38,13 +38,13 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, doLWrad, & ! Logical flag for longwave radiation call doLWclrsky, & ! Compute clear-sky fluxes for clear-sky heating-rate? use_LW_jacobian, & ! Compute Jacobian of LW to update radiative fluxes between radiation calls? - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! doGP_lwscat ! Include scattering in LW cloud-optics? integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! nGauss_angles ! Number of angles used in Gaussian quadrature real(kind_phys), dimension(lw_gas_props%get_nband(),ncol), intent(in) :: & sfc_emiss_byband ! Surface emissivity in each band diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 6b5b6f308..a88768474 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -395,12 +395,13 @@ end subroutine rrtmgp_sw_cloud_optics_init !! \htmlinclude rrtmgp_sw_cloud_optics.html !! subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, & - nCol, nLev, nDay, nbndsGPsw, idxday, cld_frac, cld_lwp, cld_reliq, cld_iwp, & - cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, cnv_cld_lwp, & - cnv_cld_reliq, cnv_cld_iwp, cnv_cld_reice, sw_optical_props_cloudsByBand, & - sw_optical_props_cnvcloudsByBand, sw_optical_props_precipByBand, cldtausw, & - errmsg, errflg) + doGP_cldoptics_PADE, doGP_cldoptics_LUT, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & + imfdeepcnv_samf, nCol, nLev, nDay, nbndsGPsw, idxday, cld_frac, cld_lwp, cld_reliq, & + cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & + cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_mynn_lwp, cld_mynn_reliq,& + cld_mynn_iwp, cld_mynn_reice, sw_optical_props_cloudsByBand, & + sw_optical_props_cnvcloudsByBand, sw_optical_props_precipByBand, & + sw_optical_props_MYNNcloudsByBand, cldtausw, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -408,16 +409,17 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw doG_cldoptics, & ! Use legacy RRTMG cloud-optics? doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf ! + do_mynnedmf ! integer, intent(in) :: & nbndsGPsw, & ! Number of shortwave bands nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels nday, & ! Number of daylit points. icliq_sw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) - icice_sw ! Choice of treatment of ice cloud optical properties (RRTMG legacy) + icice_sw, & ! Choice of treatment of ice cloud optical properties (RRTMG legacy) + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf ! integer,intent(in),dimension(ncol) :: & idxday ! Indices for daylit points. real(kind_phys), dimension(ncol,nLev),intent(in) :: & @@ -431,10 +433,14 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw cld_rwp, & ! Cloud rain water path cld_rerain, & ! Cloud rain effective radius precip_frac, & ! Precipitation fraction by layer - cnv_cld_lwp, & ! Water path for convective liquid cloud-particles (microns) - cnv_cld_reliq, & ! Effective radius for convective liquid cloud-particles (microns) - cnv_cld_iwp, & ! Water path for convective ice cloud-particles (microns) - cnv_cld_reice ! Effective radius for convective ice cloud-particles (microns) + cld_cnv_lwp, & ! Water path for convective liquid cloud-particles (microns) + cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) + cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) + cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) + cld_mynn_lwp, & + cld_mynn_reliq, & + cld_mynn_iwp, & + cld_mynn_reice ! Outputs character(len=*), intent(out) :: & errmsg ! CCPP error message @@ -442,7 +448,8 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw errflg ! CCPP error flag type(ty_optical_props_2str),intent(out) :: & sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) - sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (convectivecloud) + sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (convective cloud) + sw_optical_props_MYNNcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (MYNN PBL cloud) sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (cloud precipitation) real(kind_phys), dimension(ncol,NLev), intent(out) :: & cldtausw ! Approx 10.mu band layer cloud optical depth @@ -471,11 +478,6 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw sw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys sw_optical_props_cloudsByBand%ssa(:,:,:) = 1._kind_phys sw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cnvcloudsByBand',& - sw_optical_props_cnvcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - sw_optical_props_cnvcloudsByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_cnvcloudsByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_cnvcloudsByBand%g(:,:,:) = 0._kind_phys call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_precipByBand',& sw_optical_props_precipByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) @@ -493,11 +495,17 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw ! in each band (tau,ssa,g) ! ii) Convective cloud-optics if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cnvcloudsByBand',& + sw_optical_props_cnvcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + sw_optical_props_cnvcloudsByBand%tau(:,:,:) = 0._kind_phys + sw_optical_props_cnvcloudsByBand%ssa(:,:,:) = 1._kind_phys + sw_optical_props_cnvcloudsByBand%g(:,:,:) = 0._kind_phys + call check_error_msg('rrtmgp_sw_cloud_optics_run - convective clouds',sw_cloud_props%cloud_optics(& - cnv_cld_lwp(idxday(1:nday),:), & ! IN - Convective cloud liquid water path - cnv_cld_iwp(idxday(1:nday),:), & ! IN - Convective cloud ice water path - cnv_cld_reliq(idxday(1:nday),:), & ! IN - Convective cloud liquid effective radius - cnv_cld_reice(idxday(1:nday),:), & ! IN - Convective cloud ice effective radius + cld_cnv_lwp(idxday(1:nday),:), & ! IN - Convective cloud liquid water path + cld_cnv_iwp(idxday(1:nday),:), & ! IN - Convective cloud ice water path + cld_cnv_reliq(idxday(1:nday),:), & ! IN - Convective cloud liquid effective radius + cld_cnv_reice(idxday(1:nday),:), & ! IN - Convective cloud ice effective radius sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, ! in each band (tau,ssa,g) endif diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta index b53481d21..b2f7f48f6 100644 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ b/physics/rrtmgp_sw_cloud_optics.meta @@ -147,6 +147,13 @@ dimensions = () type = logical 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 [imfdeepcnv] standard_name = control_for_deep_convection_scheme long_name = flag for mass-flux deep convection scheme @@ -248,7 +255,7 @@ type = real kind = kind_phys intent = in -[cnv_cld_lwp] +[cld_cnv_lwp] standard_name = convective_cloud_liquid_water_path long_name = layer convective cloud liquid water path units = g m-2 @@ -256,7 +263,7 @@ type = real kind = kind_phys intent = in -[cnv_cld_iwp] +[cld_cnv_iwp] standard_name = convective_cloud_ice_water_path long_name = layer convective cloud ice water path units = g m-2 @@ -264,7 +271,7 @@ type = real kind = kind_phys intent = in -[cnv_cld_reliq] +[cld_cnv_reliq] standard_name = mean_effective_radius_for_liquid_convective_cloud long_name = mean effective radius for liquid convective cloud units = um @@ -272,7 +279,7 @@ type = real kind = kind_phys intent = in -[cnv_cld_reice] +[cld_cnv_reice] standard_name = mean_effective_radius_for_ice_convective_cloud long_name = mean effective radius for ice convective cloud units = um @@ -280,6 +287,38 @@ type = real kind = kind_phys intent = in +[cld_mynn_lwp] + standard_name = MYNN_SGS_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_mynn_iwp] + standard_name = MYNN_SGS_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_mynn_reliq] + standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud + long_name = mean effective radius for liquid MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_mynn_reice] + standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud + long_name = mean effective radius for ice MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [nbndsGPsw] standard_name = number_of_shortwave_bands long_name = number of sw bands used in RRTMGP @@ -322,6 +361,13 @@ dimensions = () type = ty_optical_props_2str intent = out +[sw_optical_props_MYNNcloudsByBand] + standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out [cldtausw] standard_name = cloud_optical_depth_layers_at_0p55mu_band long_name = approx .55mu band layer cloud optical depth diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 index 10ac6b564..b6c251166 100644 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -21,21 +21,21 @@ module rrtmgp_sw_cloud_sampling subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, & iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, & isubc_sw,icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param,& - imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, cnv_cloud_overlap_param, cnv_cldfrac, & + imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, cnv_cloud_overlap_param, cld_cnv_frac, & sw_optical_props_cnvcloudsByBand, sw_optical_props_cloudsByBand, & sw_optical_props_precipByBand, sw_optical_props_clouds, sw_optical_props_cnvclouds, & sw_optical_props_precip, errmsg, errflg) ! Inputs logical, intent(in) :: & - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! doSWrad ! Logical flag for shortwave radiation call integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nDay, & ! Number of daylit points. nLev, & ! Number of vertical layers + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! iovr, & ! Choice of cloud-overlap method iovr_convcld, & ! Choice of convective cloud-overlap method iovr_max, & ! Flag for maximum cloud overlap method @@ -54,7 +54,7 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, ! random numbers. when isubc_sw /=2, it will not be used. real(kind_phys), dimension(ncol,nLev),intent(in) :: & cld_frac, & ! Total cloud fraction by layer - cnv_cldfrac, & ! Convective cloud fraction by layer + cld_cnv_frac, & ! Convective cloud fraction by layer precip_frac ! Precipitation fraction by layer real(kind_phys), dimension(ncol,nLev), intent(in) :: & cloud_overlap_param, & ! Cloud overlap parameter @@ -170,16 +170,16 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, ! Maximum-random, random or maximum overlap if (iovr_convcld == iovr_maxrand .or. iovr_convcld == iovr_max .or. iovr_convcld == iovr_rand) then - call sampled_mask(rng3D, cnv_cldfrac(idxday(1:nDay),:), maskMCICA) + call sampled_mask(rng3D, cld_cnv_frac(idxday(1:nDay),:), maskMCICA) endif ! Exponential decorrelation length overlap if (iovr_convcld == iovr_dcorr) then - call sampled_mask(rng3D, cnv_cldfrac(idxday(1:nDay),:), maskMCICA, & + call sampled_mask(rng3D, cld_cnv_frac(idxday(1:nDay),:), maskMCICA, & overlap_param = cnv_cloud_overlap_param(idxday(1:nDay),1:nLev-1),& randoms2 = rng3D2) endif if (iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then - call sampled_mask(rng3D, cnv_cldfrac(idxday(1:nDay),:), maskMCICA, & + call sampled_mask(rng3D, cld_cnv_frac(idxday(1:nDay),:), maskMCICA, & overlap_param = cnv_cloud_overlap_param(idxday(1:nDay),1:nLev-1)) endif diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta index 72766bfbf..1415108f8 100644 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ b/physics/rrtmgp_sw_cloud_sampling.meta @@ -149,7 +149,7 @@ type = real kind = kind_phys intent = in -[cnv_cldfrac] +[cld_cnv_frac] standard_name = convective_cloud_fraction_for_RRTMGP long_name = layer convective cloud fraction units = frac diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index c7a065019..c0c59f3dc 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -34,15 +34,15 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz ! Inputs logical, intent(in) :: & top_at_1, & ! Vertical ordering flag - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! doSWrad, & ! Flag to calculate SW irradiances doSWclrsky ! Compute clear-sky fluxes? integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nday, & ! Number of daytime points nLev, & ! Number of vertical levels + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! iSFC ! Vertical index for surface-level integer, intent(in), dimension(ncol) :: & idxday ! Index array for daytime points From fb7003bd9f1d247ac0d691b0127e2b49211c0ec1 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Sat, 5 Mar 2022 00:41:59 +0000 Subject: [PATCH 085/217] Added MYNN-EDMF optical properties to RRTMGP RTE --- physics/rrtmgp_lw_cloud_optics.F90 | 34 +++++++++++----- physics/rrtmgp_lw_rte.F90 | 30 +++++++++----- physics/rrtmgp_lw_rte.meta | 14 +++++++ physics/rrtmgp_sw_cloud_optics.F90 | 64 +++++++++++++++--------------- physics/rrtmgp_sw_rte.F90 | 64 +++++++++++++++++------------- physics/rrtmgp_sw_rte.meta | 14 +++++++ 6 files changed, 139 insertions(+), 81 deletions(-) diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 3068ff1b5..99fbdfb99 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -440,7 +440,7 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw type(ty_optical_props_2str),intent(inout) :: & lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) - lw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (MYNN-PBL cloud) + lw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (MYNN-PBL cloud) lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) real(kind_phys), dimension(ncol,nLev), intent(inout) :: & cldtaulw ! Approx 10.mu band layer cloud optical depth @@ -461,16 +461,19 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw if (.not. doLWrad) return - lw_optical_props_cloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - lw_optical_props_cnvcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - lw_optical_props_precipByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + lw_optical_props_cloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + lw_optical_props_cnvcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + lw_optical_props_MYNNcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + lw_optical_props_precipByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() do iBand=1,lw_gas_props%get_nband() - lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_cnvcloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_precipByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_cloudsByBand%gpt2band(iBand) = iBand - lw_optical_props_cnvcloudsByBand%gpt2band(iBand) = iBand - lw_optical_props_precipByBand%gpt2band(iBand) = iBand + lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_cnvcloudsByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_MYNNcloudsByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_precipByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_cloudsByBand%gpt2band(iBand) = iBand + lw_optical_props_cnvcloudsByBand%gpt2band(iBand) = iBand + lw_optical_props_MYNNcloudsByBand%gpt2band(iBand) = iBand + lw_optical_props_precipByBand%gpt2band(iBand) = iBand end do ! Compute cloud-optics for RTE. @@ -495,6 +498,17 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw ! in each band endif + ! iii) MYNN cloud-optics + if (do_mynnedmf) then + call check_error_msg('rrtmgp_lw_MYNNcloud_optics_run - MYNN-EDMF cloud',lw_cloud_props%cloud_optics(& + cld_mynn_lwp, & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) + cld_mynn_iwp, & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) + cld_mynn_reliq, & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) + cld_mynn_reice, & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) + lw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties + ! in each band + endif + ! iii) Cloud precipitation optics: rain and snow(+groupel) do iCol=1,nCol do iLay=1,nLev diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index b500e1691..cea010aa2 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -26,10 +26,11 @@ end subroutine rrtmgp_lw_rte_init !! \htmlinclude rrtmgp_lw_rte_run.html !! subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & - nLev, top_at_1, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, sfc_emiss_byband, & - sources, lw_optical_props_clrsky, lw_optical_props_clouds, lw_optical_props_precip, & - lw_optical_props_cnvclouds, lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky,& - fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, & + nLev, top_at_1, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, & + sfc_emiss_byband, sources, lw_optical_props_clrsky, lw_optical_props_clouds, & + lw_optical_props_precip, lw_optical_props_cnvclouds, & + lw_optical_props_MYNNcloudsByBand, lw_optical_props_aerosol, nGauss_angles, & + fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac,& fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg) ! Inputs @@ -38,6 +39,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, doLWrad, & ! Logical flag for longwave radiation call doLWclrsky, & ! Compute clear-sky fluxes for clear-sky heating-rate? use_LW_jacobian, & ! Compute Jacobian of LW to update radiative fluxes between radiation calls? + do_mynnedmf, & ! Flag for MYNN-EDMF PBL cloud scheme doGP_lwscat ! Include scattering in LW cloud-optics? integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints @@ -47,16 +49,17 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, imfdeepcnv_samf, & ! nGauss_angles ! Number of angles used in Gaussian quadrature real(kind_phys), dimension(lw_gas_props%get_nband(),ncol), intent(in) :: & - sfc_emiss_byband ! Surface emissivity in each band + sfc_emiss_byband ! Surface emissivity in each band type(ty_source_func_lw),intent(in) :: & - sources ! RRTMGP DDT: longwave source functions + sources ! RRTMGP DDT: longwave source functions type(ty_optical_props_1scl),intent(inout) :: & - lw_optical_props_aerosol, &! RRTMGP DDT: longwave aerosol radiative properties - lw_optical_props_clrsky ! RRTMGP DDT: longwave clear-sky radiative properties + lw_optical_props_aerosol, &! RRTMGP DDT: longwave aerosol optical properties + lw_optical_props_clrsky ! RRTMGP DDT: longwave clear-sky optical properties type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_clouds, &! RRTMGP DDT: longwave cloud radiative properties - lw_optical_props_precip, &! RRTMGP DDT: longwave precipitation radiative properties - lw_optical_props_cnvclouds ! RRTMGP DDT: longwave convective cloud radiative properties + lw_optical_props_clouds, & ! RRTMGP DDT: longwave cloud optical properties + lw_optical_props_precip, & ! RRTMGP DDT: longwave precipitation optical properties + lw_optical_props_cnvclouds, & ! RRTMGP DDT: longwave convective cloud optical properties + lw_optical_props_MYNNcloudsByBand ! RRTMGP DDT: longwave MYNN-EDMF PBL cloud optical properties ! Outputs real(kind_phys), dimension(ncol,nLev+1), intent(inout) :: & fluxlwUP_jac, & ! Jacobian of upwelling LW surface radiation (W/m2/K) @@ -134,6 +137,11 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_cnvclouds%increment(lw_optical_props_clrsky)) endif + ! Include MYNN-EDMF PBL clouds? + if (do_mynnedmf) then + call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_MYNNcloudsByBand%increment(lw_optical_props_clrsky)) + endif + ! Add in precipitation call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_precip%increment(lw_optical_props_clouds)) diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 517900773..13e5e0204 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -57,6 +57,13 @@ dimensions = () type = integer 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 [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -121,6 +128,13 @@ dimensions = () type = ty_optical_props_2str intent = inout +[lw_optical_props_MYNNcloudsByBand] + standard_name = longwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout [lw_optical_props_aerosol] standard_name = longwave_optical_properties_for_aerosols long_name = Fortran DDT containing RRTMGP optical properties diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index a88768474..8b2986b33 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -473,44 +473,50 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw ! Compute cloud/precipitation optics. if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then + ! i) Cloud-optics. call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cloudsByBand',& sw_optical_props_cloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - sw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_cloudsByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys - - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_precipByBand',& - sw_optical_props_precipByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys - ! i) Cloud-optics. call check_error_msg('rrtmgp_sw_cloud_optics_run - clouds',sw_cloud_props%cloud_optics(& - cld_lwp(idxday(1:nday),:), & ! IN - Cloud liquid water path - cld_iwp(idxday(1:nday),:), & ! IN - Cloud ice water path - cld_reliq(idxday(1:nday),:), & ! IN - Cloud liquid effective radius - cld_reice(idxday(1:nday),:), & ! IN - Cloud ice effective radius - sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) + cld_lwp(idxday(1:nday),:), & ! IN - Cloud liquid water path + cld_iwp(idxday(1:nday),:), & ! IN - Cloud ice water path + cld_reliq(idxday(1:nday),:), & ! IN - Cloud liquid effective radius + cld_reice(idxday(1:nday),:), & ! IN - Cloud ice effective radius + sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + ! ii) Convective cloud-optics if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cnvcloudsByBand',& sw_optical_props_cnvcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - sw_optical_props_cnvcloudsByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_cnvcloudsByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_cnvcloudsByBand%g(:,:,:) = 0._kind_phys call check_error_msg('rrtmgp_sw_cloud_optics_run - convective clouds',sw_cloud_props%cloud_optics(& - cld_cnv_lwp(idxday(1:nday),:), & ! IN - Convective cloud liquid water path - cld_cnv_iwp(idxday(1:nday),:), & ! IN - Convective cloud ice water path - cld_cnv_reliq(idxday(1:nday),:), & ! IN - Convective cloud liquid effective radius - cld_cnv_reice(idxday(1:nday),:), & ! IN - Convective cloud ice effective radius - sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) + cld_cnv_lwp(idxday(1:nday),:), & ! IN - Convective cloud liquid water path + cld_cnv_iwp(idxday(1:nday),:), & ! IN - Convective cloud ice water path + cld_cnv_reliq(idxday(1:nday),:), & ! IN - Convective cloud liquid effective radius + cld_cnv_reice(idxday(1:nday),:), & ! IN - Convective cloud ice effective radius + sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) endif - ! iii) Cloud precipitation optics: rain and snow(+groupel) + ! iii) MYNN cloud-optics + if (do_mynnedmf) then + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_MYNNcloudsByBand',& + sw_optical_props_MYNNcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + + call check_error_msg('rrtmgp_sw_MYNNcloud_optics_run - MYNN-EDMF cloud',sw_cloud_props%cloud_optics(& + cld_mynn_lwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) + cld_mynn_iwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) + cld_mynn_reliq(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) + cld_mynn_reice(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) + sw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties + ! in each band + endif + + ! iv) Cloud precipitation optics: rain and snow(+groupel) + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_precipByBand',& + sw_optical_props_precipByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + do iDay=1,nDay do iLay=1,nLev if (cld_frac(idxday(iDay),iLay) .gt. 1.e-12_kind_phys) then @@ -548,14 +554,8 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw if (doG_cldoptics) then call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_cloudsByBand%alloc_2str(& nday, nLev, sw_gas_props%get_band_lims_wavenumber())) - sw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_cloudsByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_precipByBand%alloc_2str(& nday, nLev, sw_gas_props%get_band_lims_wavenumber())) - sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys ! RRTMG cloud(+precipitation) optics if (any(cld_frac .gt. 0)) then diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index c0c59f3dc..8a71b4428 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -25,46 +25,49 @@ end subroutine rrtmgp_sw_rte_init !! \htmlinclude rrtmgp_sw_rte.html !! subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay,& - t_lay, top_at_1, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, iSFC, sfc_alb_nir_dir, & - sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, & + t_lay, top_at_1, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, iSFC, & + sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, & sw_optical_props_clrsky, sw_optical_props_clouds, sw_optical_props_precip, & - sw_optical_props_cnvclouds, sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, & - fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) + sw_optical_props_cnvclouds, sw_optical_props_MYNNcloudsByBand, & + sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, & + fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) ! Inputs logical, intent(in) :: & - top_at_1, & ! Vertical ordering flag - doSWrad, & ! Flag to calculate SW irradiances - doSWclrsky ! Compute clear-sky fluxes? + top_at_1, & ! Vertical ordering flag + do_mynnedmf, & ! Flag for MYNN-EDMG PBL cloud scheme + doSWrad, & ! Flag to calculate SW irradiances + doSWclrsky ! Compute clear-sky fluxes? integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nday, & ! Number of daytime points - nLev, & ! Number of vertical levels - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! - iSFC ! Vertical index for surface-level + nCol, & ! Number of horizontal gridpoints + nday, & ! Number of daytime points + nLev, & ! Number of vertical levels + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! + iSFC ! Vertical index for surface-level integer, intent(in), dimension(ncol) :: & - idxday ! Index array for daytime points + idxday ! Index array for daytime points real(kind_phys),intent(in), dimension(ncol) :: & - coszen ! Cosize of SZA + coszen ! Cosize of SZA real(kind_phys), dimension(ncol,NLev), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay ! Temperature (K) + p_lay, & ! Pressure @ model layer-centers (Pa) + t_lay ! Temperature (K) type(ty_optical_props_2str),intent(inout) :: & - sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties + sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties type(ty_optical_props_2str),intent(in) :: & - sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud radiative properties - sw_optical_props_cnvclouds, & ! RRTMGP DDT: shortwave convecive cloud radiative properties - sw_optical_props_precip, & ! RRTMGP DDT: shortwave precipitation radiative properties - sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol radiative properties + sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud optical properties + sw_optical_props_cnvclouds, & ! RRTMGP DDT: shortwave convecive cloud optical properties + sw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: shortwave MYNN-EDMF PBL cloud optical properties + sw_optical_props_precip, & ! RRTMGP DDT: shortwave precipitation optical properties + sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol optical properties real(kind_phys), dimension(sw_gas_props%get_nband(),ncol), intent(in) :: & - sfc_alb_nir_dir, & ! Surface albedo (direct) - sfc_alb_nir_dif, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir, & ! Surface albedo (direct) - sfc_alb_uvvis_dif ! Surface albedo (diffuse) + sfc_alb_nir_dir, & ! Surface albedo (direct) + sfc_alb_nir_dif, & ! Surface albedo (diffuse) + sfc_alb_uvvis_dir, & ! Surface albedo (direct) + sfc_alb_uvvis_dif ! Surface albedo (diffuse) real(kind_phys), dimension(ncol,sw_gas_props%get_ngpt()), intent(in) :: & - toa_src_sw ! TOA incident spectral flux (W/m2) + toa_src_sw ! TOA incident spectral flux (W/m2) ! Outputs character(len=*), intent(out) :: & @@ -158,6 +161,11 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_cnvclouds%increment(sw_optical_props_clrsky)) endif + ! Include MYNN-EDMF PBL cloud? + if (do_mynnedmf) then + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_MYNNcloudsByBand%increment(sw_optical_props_clrsky)) + endif + ! All-sky fluxes (clear-sky + clouds + precipitation) call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_precip%increment(sw_optical_props_clrsky)) call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clouds%increment(sw_optical_props_clrsky)) diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index aa8a8d4ec..b4b5e8bf4 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -94,6 +94,13 @@ dimensions = () type = logical 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 [iSFC] standard_name = vertical_index_for_surface_in_RRTMGP long_name = index for surface layer in RRTMGP @@ -137,6 +144,13 @@ dimensions = () type = ty_optical_props_2str intent = in +[sw_optical_props_MYNNcloudsByBand] + standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in [sw_optical_props_aerosol] standard_name = shortwave_optical_properties_for_aerosols long_name = Fortran DDT containing RRTMGP optical properties From b90d4e2c7b2770295406d5344806fb52c1c1d41b Mon Sep 17 00:00:00 2001 From: helin wei Date: Mon, 7 Mar 2022 16:08:57 +0000 Subject: [PATCH 086/217] add canopy heat storage and gvf impact on thermal conductivity --- physics/module_sf_noahmp_glacier.f90 | 3 +- physics/module_sf_noahmplsm.f90 | 88 ++++++++++++++++++---------- physics/sfc_diag_post.F90 | 12 +++- physics/sfc_diag_post.meta | 16 +++++ physics/sfc_noahmp_drv.F90 | 4 +- 5 files changed, 88 insertions(+), 35 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index c4c03aaf8..1ea4a45b8 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -1152,7 +1152,8 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! the following only applies to opt_sfc =3, opt_sfc = 1 still done its old way snwd = snowh*1000.0 - zlvli = zlvl - zpd +! zlvli = zlvl - zpd + zlvli = zlvl ! fv = ustarx ! the input maybe too high for glacial fv = ur*vkc/log(zlvli/z0m) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 0fc4e8948..0913531f8 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -678,18 +678,21 @@ subroutine noahmp_sflx (parameters, & real (kind=kind_phys) :: latheag !< latent heat vap./sublimation (j/kg) logical :: frozen_ground !< used to define latent heat pathway logical :: frozen_canopy !< used to define latent heat pathway - LOGICAL :: dveg_active !< flag to run dynamic vegetation - LOGICAL :: crop_active !< flag to run crop model + logical :: dveg_active !< flag to run dynamic vegetation + logical :: crop_active !< flag to run crop model +! add canopy heat storage (C.He added based on GY Niu's communication) + real :: canhs ! canopy heat storage change w/m2 ! intent (out) variables need to be assigned a value. these normally get assigned values ! only if dveg == 2. nee = 0.0 npp = 0.0 gpp = 0.0 - pahv = 0. - pahg = 0. - pahb = 0. - pah = 0. + pahv = 0. + pahg = 0. + pahb = 0. + pah = 0. + canhs = 0. ! -------------------------------------------------------------------------------------------------- ! re-process atmospheric forcing @@ -774,7 +777,7 @@ subroutine noahmp_sflx (parameters, & co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in elai ,esai ,fwet ,foln , & !in - fveg ,pahv ,pahg ,pahb , & !in + fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in z0wrf ,z0hwrf , & !out @@ -797,7 +800,7 @@ subroutine noahmp_sflx (parameters, & t2mv ,t2mb ,fsrv , & fsrg ,rssun ,rssha ,albd ,albi ,albsnd,albsni, bgap ,wgap, tgv,tgb,& q1 ,q2v ,q2b ,q2e ,chv ,chb , & !out - emissi ,pah , & + emissi ,pah ,canhs, & shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out qsfc = q1 ! @@ -868,9 +871,9 @@ subroutine noahmp_sflx (parameters, & nsnow ,ist ,errwat ,iloc , jloc ,fveg , & sav ,sag ,fsrv ,fsrg ,zwt ,pah , & #ifdef CCPP - pahv ,pahg ,pahb ,errmsg, errflg) !in ( except errwat [out] and errmsg, errflg [inout] ) + pahv ,pahg ,pahb ,canhs,errmsg, errflg) !in ( except errwat [out] and errmsg, errflg [inout] ) #else - pahv ,pahg ,pahb ) !in ( except errwat, which is out ) + pahv ,pahg ,pahb, canhs ) !in ( except errwat, which is out ) #endif #ifdef CCPP @@ -1405,9 +1408,9 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & nsnow ,ist ,errwat, iloc ,jloc ,fveg , & sav ,sag ,fsrv ,fsrg ,zwt ,pah , & #ifdef CCPP - pahv ,pahg ,pahb ,errmsg, errflg) + pahv ,pahg ,pahb ,canhs,errmsg, errflg) #else - pahv ,pahg ,pahb ) + pahv ,pahg ,pahb ,canhs) #endif ! -------------------------------------------------------------------------------------------------- ! check surface energy balance and water balance @@ -1456,6 +1459,7 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & real (kind=kind_phys), intent(in) :: pahv !precipitation advected heat - total (w/m2) real (kind=kind_phys), intent(in) :: pahg !precipitation advected heat - total (w/m2) real (kind=kind_phys), intent(in) :: pahb !precipitation advected heat - total (w/m2) + real (kind=kind_phys), intent(in) :: canhs !canopy heat storage change (w/m2) C.He added based on GY Niu's communication #ifdef CCPP character(len=*) , intent(inout) :: errmsg @@ -1501,7 +1505,7 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & #endif end if - erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) +pah + erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil+canhs) +pah ! erreng = fveg*sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) if(abs(erreng) > 0.01) then write(message,*) 'erreng =',erreng,' at i,j: ',iloc,jloc @@ -1551,6 +1555,12 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) #else call wrf_message(trim(message)) +#endif + write(message,'(a17,f10.4)') "canopy heat storage: ",canhs +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else + call wrf_message(trim(message)) #endif write(message,'(a17,4f10.4)') "precip advected: ",pah,pahv,pahg,pahb #ifdef CCPP @@ -1605,7 +1615,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in elai ,esai ,fwet ,foln , & !in - fveg ,pahv ,pahg ,pahb , & !in + fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in z0wrf ,z0hwrf , & !out @@ -1627,7 +1637,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in qc ,qsfc ,psfc , & !in t2mv ,t2mb ,fsrv , & fsrg ,rssun ,rssha ,albd ,albi,albsnd ,albsni,bgap ,wgap,tgv,tgb,& - q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah ,& + q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah,canhs,& shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out !jref:end @@ -1701,6 +1711,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: esai !lai adjusted for burying by snow real (kind=kind_phys) , intent(in) :: fwet !fraction of canopy that is wet [-] real (kind=kind_phys) , intent(in) :: fveg !greeness vegetation fraction (-) + real (kind=kind_phys) , intent(in) :: shdfac !< green vegetation fraction [0.0-1.0] real (kind=kind_phys) , intent(in) :: lat !latitude (radians) real (kind=kind_phys) , intent(in) :: canliq !canopy-intercepted liquid water (mm) real (kind=kind_phys) , intent(in) :: canice !canopy-intercepted ice mass (mm) @@ -1774,6 +1785,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(out) :: t2mb !2-m air temperature over bare ground part [k] real (kind=kind_phys) , intent(out) :: bgap real (kind=kind_phys) , intent(out) :: wgap + real (kind=kind_phys) , intent(out) :: canhs !canopy heat storage change (w/m2) real (kind=kind_phys), dimension(1:2) , intent(out) :: albd !albedo (direct) real (kind=kind_phys), dimension(1:2) , intent(out) :: albi !albedo (diffuse) real (kind=kind_phys), dimension(1:2) , intent(out) :: albsnd !snow albedo (direct) @@ -2032,7 +2044,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , & !in + lat ,z0m ,zlvl ,vegtyp , fveg, & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2157,7 +2169,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in fwet ,laisun ,laisha ,cwp ,dzsnso , & !in - zlvl ,zpd ,z0m ,fveg , & !in + zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in @@ -2172,7 +2184,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in #endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,ghv , & !out - t2mv ,psnsun ,psnsha ,csigmaf1, & !out + t2mv ,psnsun ,psnsha ,csigmaf1,canhs, & !out !jref:start qc ,qsfc ,psfc , & !in q2v ,chv2, chleaf, chuc) !inout @@ -2196,7 +2208,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in emg ,stc ,df ,rsurf ,latheag , & !in gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in - thsfc_loc, prslkix,prsik1x,prslk1x,fveg,garea1, & !in + thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in #ifdef CCPP tgb ,cmb ,chb, ustarx,errmsg ,errflg , & !inout #else @@ -2415,7 +2427,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , & !in + lat ,z0m ,zlvl ,vegtyp , fveg,& !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2441,6 +2453,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) integer , intent(in) :: vegtyp !vegtyp type + real (kind=kind_phys), intent(in) :: fveg !green vegetation fraction [0.0-1.0] ! outputs real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] @@ -2456,6 +2469,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), dimension(-nsnow+1: 0) :: cvsno !volumetric specific heat (j/m3/k) real (kind=kind_phys), dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) real (kind=kind_phys), dimension( 1:nsoil) :: sice !soil ice content + real (kind=kind_phys), parameter :: sbeta = -2.0 ! -------------------------------------------------------------------------------------------------- ! compute snow thermal conductivity and heat capacity @@ -2488,6 +2502,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) + df = df * exp (sbeta * fveg) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -3634,7 +3649,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in fwet ,laisun ,laisha ,cwp ,dzsnso , & !in - zlvl ,zpd ,z0m ,fveg, & !in + zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in @@ -3649,7 +3664,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & #endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,gh , & !out - t2mv ,psnsun ,psnsha ,csigmaf1, & !out + t2mv ,psnsun ,psnsha ,csigmaf1,canhs, & !out qc ,qsfc ,psfc , & !in q2v ,cah2 ,chleaf ,chuc ) !inout @@ -3658,7 +3673,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! ground (tg) temperatures that balance the surface energy budgets ! vegetated: -! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] = 0 +! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] + canhs(tv) = 0 ! -sag + irg[tg] + shg[tg] + evg[tg] + gh[tg] = 0 ! -------------------------------------------------------------------------------------------------- implicit none @@ -3673,6 +3688,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & integer, intent(in) :: isnow !actual no. of snow layers integer, intent(in) :: vegtyp !vegetation physiology type real (kind=kind_phys), intent(in) :: fveg !greeness vegetation fraction (-) + real (kind=kind_phys), intent(in) :: shdfac !greeness vegetation fraction (-) real (kind=kind_phys), intent(in) :: sav !solar rad absorbed by veg (w/m2) real (kind=kind_phys), intent(in) :: sag !solar rad absorbed by ground (w/m2) real (kind=kind_phys), intent(in) :: lwdn !atmospheric longwave radiation (w/m2) @@ -3753,7 +3769,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & #endif ! output -! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil = 0 +! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil + canhs = 0 real (kind=kind_phys), intent(out) :: tauxv !wind stress: e-w (n/m2) real (kind=kind_phys), intent(out) :: tauyv !wind stress: n-s (n/m2) real (kind=kind_phys), intent(out) :: irc !net longwave radiation (w/m2) [+= to atm] @@ -3770,6 +3786,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(out) :: csigmaf1 real (kind=kind_phys), intent(out) :: chleaf !leaf exchange coefficient real (kind=kind_phys), intent(out) :: chuc !under canopy exchange coefficient + real (kind=kind_phys), intent(out) :: canhs !canopy heat storage change (w/m2) real (kind=kind_phys), intent(out) :: q2v real (kind=kind_phys) :: cah !sensible heat conductance, canopy air to zlvl air (m/s) @@ -3864,8 +3881,9 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: ch2v !exchange coefficient for 2m over vegetation. real (kind=kind_phys) :: cq2v !exchange coefficient for 2m over vegetation. real (kind=kind_phys) :: eah2 !2m vapor pressure over canopy - real (kind=kind_phys) :: qfx !moisture flux + real (kind=kind_phys) :: qfx !moisture flux real (kind=kind_phys) :: e1 + real (kind=kind_phys) :: hcv !canopy heat capacity j/m2/k, C.He added real (kind=kind_phys) :: vaie !total leaf area index + stem area index,effective @@ -3929,7 +3947,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! for sfcdiff3 snwd = snowh*1000.0 - zlvlv = zlvl - zpd +! zlvlv = zlvl - zpd + zlvlv = zlvl virtfacv = 1.0 + 0.61 * max(qair, 1.e-8) tv1v = sfctmp * virtfacv @@ -4027,7 +4046,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! -- tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(fveg, 0.1_kind_phys) + tem2 = max(shdfac, 0.1_kind_phys) zvfun1= sqrt(tem1 * tem2) gdx=sqrt(garea1) if(opt_sfc == 1 .or. opt_sfc == 2) then @@ -4156,14 +4175,19 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & evc = min(canice*latheav/dt,evc) end if +! canopy heat capacity + hcv = 0.02*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice !j/m2/k + b = sav-irc-shc-evc-tr+pahv !additional w/m2 - a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity +! a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity + a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) + hcv/dt !volumetric heat capacity dtv = b/a irc = irc + fveg*4.*cir*tv**3*dtv shc = shc + fveg*csh*dtv evc = evc + fveg*cev*destv*dtv tr = tr + fveg*ctr*destv*dtv + canhs = dtv*hcv/dt ! update vegetation surface temperature tv = tv + dtv @@ -4413,7 +4437,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & dzsnso ,zlvl ,zpd ,z0m ,fsno , & !in emg ,stc ,df ,rsurf ,lathea , & !in gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in - thsfc_loc, prslkix,prsik1x,prslk1x,fveg,garea1, & !in + thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in #ifdef CCPP tgb ,cm ,ch,ustarx,errmsg ,errflg , & !inout #else @@ -4470,6 +4494,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function real (kind=kind_phys) , intent(in) :: fveg + real (kind=kind_phys) , intent(in) :: shdfac real (kind=kind_phys) , intent(in) :: garea1 !jref:start; in @@ -4655,7 +4680,8 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! for sfcdiff3; maybe should move to inside the option ! snwd = snowh*1000.0 - zlvlb = zlvl - zpd +! zlvlb = zlvl - zpd + zlvlb = zlvl virtfacb = 1.0 + 0.61 * max(qair, 1.e-8) tv1b = sfctmp * virtfacb @@ -4672,7 +4698,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! ----------------------------------------------------------------- tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(fveg, 0.1_kind_phys) + tem2 = max(shdfac, 0.1_kind_phys) zvfun1= sqrt(tem1 * tem2) gdx=sqrt(garea1) diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90 index 6f14fe93d..36541b0fc 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/sfc_diag_post.F90 @@ -16,7 +16,7 @@ end subroutine sfc_diag_post_finalize !! #endif subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con_epsm1, pgr,& - t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & + t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg) use machine, only: kind_phys @@ -29,6 +29,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con logical , dimension(:), intent(in) :: dry real(kind=kind_phys), dimension(:), intent(in) :: pgr, u10m, v10m real(kind=kind_phys), dimension(:), intent(inout) :: t2m, q2m, tmpmin, tmpmax, spfhmin, spfhmax + real(kind=kind_phys), dimension(:), intent(inout) :: t2mmp, q2mp real(kind=kind_phys), dimension(:), intent(inout) :: wind10mmax, u10mmax, v10mmax, dpt2m character(len=*), intent(out) :: errmsg @@ -41,6 +42,15 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con errmsg = '' errflg = 0 +! if (lsm == lsm_noahmp) then +! do i=1,im +! if(dry(i)) then +! t2m(i) = t2mmp(i) +! q2m(i) = q2mp(i) +! endif +! enddo +! endif + if (lssav) then do i=1,im tmpmax(i) = max(tmpmax(i),t2m(i)) diff --git a/physics/sfc_diag_post.meta b/physics/sfc_diag_post.meta index 21d76a147..95e8d8428 100644 --- a/physics/sfc_diag_post.meta +++ b/physics/sfc_diag_post.meta @@ -74,6 +74,22 @@ type = real kind = kind_phys intent = in +[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 = out +[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 = out [t2m] standard_name = air_temperature_at_2m long_name = 2 meter temperature diff --git a/physics/sfc_noahmp_drv.F90 b/physics/sfc_noahmp_drv.F90 index 397a09674..0ebcbd615 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/sfc_noahmp_drv.F90 @@ -923,7 +923,7 @@ subroutine noahmpdrv_run & snowc (i) = snow_cover_fraction sncovr1 (i) = snow_cover_fraction -! qsurf (i) = spec_humidity_surface + qsurf (i) = spec_humidity_surface tsurf (i) = tskin(i) tvxy (i) = temperature_leaf @@ -998,7 +998,7 @@ subroutine noahmpdrv_run & cmm (i) = cmxy(i) * wind(i) snwdph (i) = snow_depth * 1000.0 ! convert from m to mm; wait after the stability call - qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) +! qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) ! ! --- change units for output From 63277493ceb380949c341bd22fd3faaf57eaa666 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 7 Mar 2022 18:35:42 +0000 Subject: [PATCH 087/217] Removed RRTMG cloud-optics option in RRTMGP. --- physics/rrtmgp_lw_cloud_optics.F90 | 49 ++++++++++++++---------------- physics/rrtmgp_sw_cloud_optics.F90 | 34 --------------------- 2 files changed, 22 insertions(+), 61 deletions(-) diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 99fbdfb99..c83929b31 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -461,25 +461,15 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw if (.not. doLWrad) return - lw_optical_props_cloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - lw_optical_props_cnvcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - lw_optical_props_MYNNcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - lw_optical_props_precipByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_cnvcloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_MYNNcloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_precipByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_cloudsByBand%gpt2band(iBand) = iBand - lw_optical_props_cnvcloudsByBand%gpt2band(iBand) = iBand - lw_optical_props_MYNNcloudsByBand%gpt2band(iBand) = iBand - lw_optical_props_precipByBand%gpt2band(iBand) = iBand - end do - ! Compute cloud-optics for RTE. if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then ! i) Cloud-optics. + lw_optical_props_cloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_cloudsByBand%gpt2band(iBand) = iBand + end do call check_error_msg('rrtmgp_lw_cloud_optics_run - clouds',lw_cloud_props%cloud_optics(& cld_lwp, & ! IN - Cloud liquid water path (g/m2) cld_iwp, & ! IN - Cloud ice water path (g/m2) @@ -489,6 +479,11 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw ! in each band ! ii) Convective cloud-optics if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then + lw_optical_props_cnvcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_cnvcloudsByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_cnvcloudsByBand%gpt2band(iBand) = iBand + end do call check_error_msg('rrtmgp_lw_cnvcloud_optics_run - convective cloud',lw_cloud_props%cloud_optics(& cld_cnv_lwp, & ! IN - Convective cloud liquid water path (g/m2) cld_cnv_iwp, & ! IN - Convective cloud ice water path (g/m2) @@ -500,6 +495,11 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw ! iii) MYNN cloud-optics if (do_mynnedmf) then + lw_optical_props_MYNNcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_MYNNcloudsByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_MYNNcloudsByBand%gpt2band(iBand) = iBand + end do call check_error_msg('rrtmgp_lw_MYNNcloud_optics_run - MYNN-EDMF cloud',lw_cloud_props%cloud_optics(& cld_mynn_lwp, & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) cld_mynn_iwp, & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) @@ -509,7 +509,12 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw ! in each band endif - ! iii) Cloud precipitation optics: rain and snow(+groupel) + ! iv) Cloud precipitation optics: rain and snow(+groupel) + lw_optical_props_precipByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_precipByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_precipByBand%gpt2band(iBand) = iBand + end do do iCol=1,nCol do iLay=1,nLev if (cld_frac(iCol,iLay) .gt. 0.) then @@ -529,17 +534,7 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw enddo enddo endif - if (doG_cldoptics) then - ! ii) RRTMG cloud-optics. - if (any(cld_frac .gt. 0)) then - call rrtmg_lw_cloud_optics(ncol, nLev, nbndsGPlw, cld_lwp, cld_reliq, cld_iwp,& - cld_reice, cld_rwp, cld_rerain, cld_swp, cld_resnow, cld_frac, icliq_lw, & - icice_lw, tau_cld, tau_precip) - lw_optical_props_cloudsByBand%tau = tau_cld - lw_optical_props_precipByBand%tau = tau_precip - endif - endif - + ! All-sky LW optical depth ~10microns (DJS asks: Same as SW, move to cloud-diagnostics?) cldtaulw = lw_optical_props_cloudsByBand%tau(:,:,7) diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 8b2986b33..d02fde7d7 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -551,40 +551,6 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw enddo enddo endif - if (doG_cldoptics) then - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_cloudsByBand%alloc_2str(& - nday, nLev, sw_gas_props%get_band_lims_wavenumber())) - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_precipByBand%alloc_2str(& - nday, nLev, sw_gas_props%get_band_lims_wavenumber())) - - ! RRTMG cloud(+precipitation) optics - if (any(cld_frac .gt. 0)) then - call rrtmg_sw_cloud_optics(nday, nLev, sw_gas_props%get_nband(), & - cld_lwp(idxday(1:nday),:), cld_reliq(idxday(1:nday),:), & - cld_iwp(idxday(1:nday),:), cld_reice(idxday(1:nday),:), & - cld_rwp(idxday(1:nday),:), cld_rerain(idxday(1:nday),:), & - cld_swp(idxday(1:nday),:), cld_resnow(idxday(1:nday),:), & - cld_frac(idxday(1:nday),:), icliq_sw, icice_sw, & - tau_cld, ssa_cld, asy_cld, & - tau_precip, ssa_precip, asy_precip) - - ! Cloud-optics (Need to reorder from G->GP band conventions) - sw_optical_props_cloudsByBand%tau(:,:,1) = tau_cld(:,:,sw_gas_props%get_nband()) - sw_optical_props_cloudsByBand%ssa(:,:,1) = ssa_cld(:,:,sw_gas_props%get_nband()) - sw_optical_props_cloudsByBand%g(:,:,1) = asy_cld(:,:,sw_gas_props%get_nband()) - sw_optical_props_cloudsByBand%tau(:,:,2:sw_gas_props%get_nband()) = tau_cld(:,:,1:sw_gas_props%get_nband()-1) - sw_optical_props_cloudsByBand%ssa(:,:,2:sw_gas_props%get_nband()) = ssa_cld(:,:,1:sw_gas_props%get_nband()-1) - sw_optical_props_cloudsByBand%g(:,:,2:sw_gas_props%get_nband()) = asy_cld(:,:,1:sw_gas_props%get_nband()-1) - ! Precipitation-optics (Need to reorder from G->GP band conventions) - sw_optical_props_precipByBand%tau(:,:,1) = tau_precip(:,:,sw_gas_props%get_nband()) - sw_optical_props_precipByBand%ssa(:,:,1) = ssa_precip(:,:,sw_gas_props%get_nband()) - sw_optical_props_precipByBand%g(:,:,1) = asy_precip(:,:,sw_gas_props%get_nband()) - sw_optical_props_precipByBand%tau(:,:,2:sw_gas_props%get_nband()) = tau_precip(:,:,1:sw_gas_props%get_nband()-1) - sw_optical_props_precipByBand%ssa(:,:,2:sw_gas_props%get_nband()) = ssa_precip(:,:,1:sw_gas_props%get_nband()-1) - sw_optical_props_precipByBand%g(:,:,2:sw_gas_props%get_nband()) = asy_precip(:,:,1:sw_gas_props%get_nband()-1) - - endif - endif ! All-sky SW optical depth ~0.55microns (DJS asks: Move to cloud diagnostics?) cldtausw(idxday(1:nDay),:) = sw_optical_props_cloudsByBand%tau(:,:,11) From ae7ac42b3679be983aac2dbd5b9f959c4f6db86f Mon Sep 17 00:00:00 2001 From: barlage Date: Mon, 7 Mar 2022 14:37:38 -0700 Subject: [PATCH 088/217] add sfcdif3 as a separate subroutine --- physics/module_sf_noahmplsm.f90 | 549 ++++++++++---------------------- 1 file changed, 167 insertions(+), 382 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 0913531f8..0248a116b 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -2184,7 +2184,8 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in #endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,ghv , & !out - t2mv ,psnsun ,psnsha ,csigmaf1,canhs, & !out + t2mv ,psnsun ,psnsha ,canhs , & !out + csigmaf1, & !out !jref:start qc ,qsfc ,psfc , & !in q2v ,chv2, chleaf, chuc) !inout @@ -3664,7 +3665,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & #endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,gh , & !out - t2mv ,psnsun ,psnsha ,csigmaf1,canhs, & !out + t2mv ,psnsun ,psnsha ,canhs , & !out + csigmaf1, & !out qc ,qsfc ,psfc , & !in q2v ,cah2 ,chleaf ,chuc ) !inout @@ -3673,7 +3675,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! ground (tg) temperatures that balance the surface energy budgets ! vegetated: -! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] + canhs(tv) = 0 +! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] + canhs[tv] = 0 ! -sag + irg[tg] + shg[tg] + evg[tg] + gh[tg] = 0 ! -------------------------------------------------------------------------------------------------- implicit none @@ -3688,7 +3690,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & integer, intent(in) :: isnow !actual no. of snow layers integer, intent(in) :: vegtyp !vegetation physiology type real (kind=kind_phys), intent(in) :: fveg !greeness vegetation fraction (-) - real (kind=kind_phys), intent(in) :: shdfac !greeness vegetation fraction (-) real (kind=kind_phys), intent(in) :: sav !solar rad absorbed by veg (w/m2) real (kind=kind_phys), intent(in) :: sag !solar rad absorbed by ground (w/m2) real (kind=kind_phys), intent(in) :: lwdn !atmospheric longwave radiation (w/m2) @@ -3703,12 +3704,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in) :: dt !time step (s) real (kind=kind_phys), intent(in) :: fsno !snow fraction - logical , intent(in) :: thsfc_loc - real (kind=kind_phys) , intent(in) :: prslkix ! in exner function - real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function - real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function - real (kind=kind_phys) , intent(in) :: garea1 ! - real (kind=kind_phys), intent(in) :: snowh !actual snow depth [m] real (kind=kind_phys), intent(in) :: fwet !wetted fraction of canopy real (kind=kind_phys), intent(in) :: cwp !canopy wind parameter @@ -3761,7 +3756,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(inout) :: tg !ground temperature (k) real (kind=kind_phys), intent(inout) :: cm !momentum drag coefficient real (kind=kind_phys), intent(inout) :: ch !sensible heat exchange coefficient - real (kind=kind_phys), intent(inout) :: ustarx !< friction velocity #ifdef CCPP character(len=*), intent(inout) :: errmsg @@ -3783,11 +3777,9 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(out) :: t2mv !2 m height air temperature (k) real (kind=kind_phys), intent(out) :: psnsun !sunlit leaf photosynthesis (umolco2/m2/s) real (kind=kind_phys), intent(out) :: psnsha !shaded leaf photosynthesis (umolco2/m2/s) - real (kind=kind_phys), intent(out) :: csigmaf1 real (kind=kind_phys), intent(out) :: chleaf !leaf exchange coefficient real (kind=kind_phys), intent(out) :: chuc !under canopy exchange coefficient real (kind=kind_phys), intent(out) :: canhs !canopy heat storage change (w/m2) - real (kind=kind_phys), intent(out) :: q2v real (kind=kind_phys) :: cah !sensible heat conductance, canopy air to zlvl air (m/s) real (kind=kind_phys) :: u10v !10 m wind speed in eastward dir (m/s) @@ -3857,22 +3849,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: ch2 !surface exchange at 2m real (kind=kind_phys) :: thstar !surface exchange at 2m - real (kind=kind_phys) :: dlf ! leaf dimension - real(kind=kind_phys) :: sigmaa ! momentum partition parameter - real(kind=kind_phys) :: kbsigmaf1 ! kb^-1 for fully convered by vegetation - real(kind=kind_phys) :: kbsigmafc ! kb^-1 under canopy ground - - real (kind=kind_phys) :: fm10 !monin-obukhov momentum adjustment at 10m - real (kind=kind_phys) :: rb1v !Bulk Richardson # over vegetation - real (kind=kind_phys) :: stress1v !Stress over vegetation - real (kind=kind_phys) :: snwd - real (kind=kind_phys) :: virtfacv - real (kind=kind_phys) :: thv1v - real (kind=kind_phys) :: tvsv - real (kind=kind_phys) :: tv1v - real (kind=kind_phys) :: zlvlv - - real (kind=kind_phys) :: thvair real (kind=kind_phys) :: thah real (kind=kind_phys) :: rahc2 !aerodynamic resistance for sensible heat (s/m) @@ -3885,14 +3861,10 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: e1 real (kind=kind_phys) :: hcv !canopy heat capacity j/m2/k, C.He added - real (kind=kind_phys) :: vaie !total leaf area index + stem area index,effective real (kind=kind_phys) :: laisune !sunlit leaf area index, one-sided (m2/m2),effective real (kind=kind_phys) :: laishae !shaded leaf area index, one-sided (m2/m2),effective - real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx,czil1 - real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 - integer :: k !index integer :: iter !iteration index @@ -3905,8 +3877,16 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & integer :: liter !last iteration - integer :: niter !for sfcdiff3 +! New variables for sfcdif3 + logical , intent(in ) :: thsfc_loc + real (kind=kind_phys), intent(in ) :: prslkix ! in exner function + real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function + real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function + real (kind=kind_phys), intent(in ) :: garea1 + real (kind=kind_phys), intent(in ) :: shdfac ! greeness vegetation fraction (-) + real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity + real (kind=kind_phys), intent( out) :: csigmaf1 ! real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 @@ -3918,11 +3898,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & mpe = 1e-6 liter = 0 - fv = ustarx - - niter = 1 - if (ur < 2.0) niter = 2 - ! --------------------------------------------------------------------------------------------- ! initialization variables that do not depend on stability iteration ! --------------------------------------------------------------------------------------------- @@ -3936,31 +3911,12 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & h = 0. qfx = 0. - csigmaf1 = 0. - ! limit lai vaie = min(6.,vai ) laisune = min(6.,laisun) laishae = min(6.,laisha) -! for sfcdiff3 - - snwd = snowh*1000.0 -! zlvlv = zlvl - zpd - zlvlv = zlvl - - virtfacv = 1.0 + 0.61 * max(qair, 1.e-8) - tv1v = sfctmp * virtfacv - - if(thsfc_loc) then ! Use local potential temperature - thv1v = sfctmp * prslkix * virtfacv - else ! Use potential temperature reference to 1000 hPa - thv1v = sfctmp / prslk1x * virtfacv - endif -! - - ! saturation vapor pressure at ground temperature t = tdc(tg) @@ -3975,8 +3931,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & qsfc = 0.622*eair/(psfc-0.378*eair) - dlf = parameters%dleaf !leaf dimension - ! canopy height hcan = parameters%hvt @@ -4024,37 +3978,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 cir = (2.-emv*(1.-emg))*emv*sb ! --------------------------------------------------------------------------------------------- - - if (opt_trs == 1) then - z0h = z0m - elseif (opt_trs == 2) then -! z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) - czil1= 10.0 ** (- (0.40/0.07) * hcan) - z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) - elseif (opt_trs == 3) then - if (vegtyp.le.5) then - z0h = z0m - else - z0h = z0m*0.01 - endif - elseif (opt_trs == 4) then - sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) - kbsigmaf1 = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) - z0h = z0m/exp(kbsigmaf1) - csigmaf1 = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m)+kbsigmaf1) ! for output for interpolation - endif -! -- - tem1 = (z0m - z0lo) / (z0up - z0lo) - tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(shdfac, 0.1_kind_phys) - zvfun1= sqrt(tem1 * tem2) - gdx=sqrt(garea1) - if(opt_sfc == 1 .or. opt_sfc == 2) then - loop1: do iter = 1, niterc ! begin stability iteration -! use newly derived z0m/z0h - if(iter == 1) then z0hg = z0mg else @@ -4089,6 +4014,15 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & cm = cm / ur endif + if(opt_sfc == 3) then + call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in + zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in + zpd ,snowh ,fveg ,garea1 ,.true. ,vaie , & !in + ustarx ,fm ,fh ,fm2 ,fh2 , & !inout + z0h ,fv ,csigmaf1,cm ,ch ) !out + + endif + ramc = max(1.,1./(cm*ur)) rahc = max(1.,1./(ch*ur)) rawc = rahc @@ -4209,135 +4143,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & end do loop1 ! end stability iteration - endif !opt_sfc 1 or 2 -! -! sfcdiff3 -! - if (opt_sfc == 3) then - - z0hg = z0mg - - do iter = 1, niter !1 or 2; depending on ur - - if(thsfc_loc) then ! Use local potential temperature - tvsv = tah * virtfacv - else ! Use potential temperature referenced to 1000 hPa - tvsv = tah/prsik1x * virtfacv - endif - - call stability & - (zlvlv, zvfun1, gdx,tv1v,thv1v, ur, z0m, z0h, tvsv, grav,thsfc_loc, & - rb1v, fm,fh,fm10,fh2,cm,ch,stress1v,fv) - - ramc = max(1.,1./(cm*ur)) - rahc = max(1.,1./(ch*ur)) - rawc = rahc - -! aerodyn resistance between heights z0g and d+z0v, rag, and leaf -! boundary layer resistance, rb - - call ragrb(parameters,iter ,vaie ,rhoair ,hg ,tah , & !in - zpd ,z0mg ,z0hg ,hcan ,uc , & !in - z0h ,fv ,cwp ,vegtyp ,mpe , & !in - tv ,mozg ,fhg ,iloc ,jloc , & !inout - ramg ,rahg ,rawg ,rb ) !out - -! es and d(es)/dt evaluated at tv - - t = tdc(tv) - call esat(t, esatw, esati, dsatw, dsati) - if (t .gt. 0.) then - estv = esatw - destv = dsatw - else - estv = esati - destv = dsati - end if - -! stomatal resistance - - if(iter == 1) then - if (opt_crs == 1) then ! ball-berry - call stomata (parameters,vegtyp,mpe ,parsun ,foln ,iloc , jloc , & !in - tv ,estv ,eah ,sfctmp,sfcprs, & !in - o2air ,co2air,igs ,btran ,rb , & !in - rssun ,psnsun) !out - - call stomata (parameters,vegtyp,mpe ,parsha ,foln ,iloc , jloc , & !in - tv ,estv ,eah ,sfctmp,sfcprs, & !in - o2air ,co2air,igs ,btran ,rb , & !in - rssha ,psnsha) !out - end if - - if (opt_crs == 2) then ! jarvis - call canres (parameters,parsun,tv ,btran ,eah ,sfcprs, & !in - rssun ,psnsun,iloc ,jloc ) !out - - call canres (parameters,parsha,tv ,btran ,eah ,sfcprs, & !in - rssha ,psnsha,iloc ,jloc ) !out - end if - end if - -! prepare for sensible heat flux above veg. - - cah = 1./rahc - cvh = 2.*vaie/rb - cgh = 1./rahg - cond = cah + cvh + cgh - ata = (sfctmp*cah + tg*cgh) / cond - bta = cvh/cond - csh = (1.-bta)*rhoair*cpair*cvh - -! prepare for latent heat flux above veg. - - caw = 1./rawc - cew = fwet*vaie/rb - ctw = (1.-fwet)*(laisune/(rb+rssun) + laishae/(rb+rssha)) - cgw = 1./(rawg+rsurf) - cond = caw + cew + ctw + cgw - aea = (eair*caw + estg*cgw) / cond - bea = (cew+ctw)/cond - cev = (1.-bea)*cew*rhoair*cpair/gammav ! barlage: change to vegetation v3.6 - ctr = (1.-bea)*ctw*rhoair*cpair/gammav - -! evaluate surface fluxes with current temperature and solve for dts - - tah = ata + bta*tv ! canopy air t. - eah = aea + bea*estv ! canopy air e - - irc = fveg*(air + cir*tv**4) - shc = fveg*rhoair*cpair*cvh * ( tv-tah) - evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 - tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav - if (tv > tfrz) then - evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6 - else - evc = min(canice*latheav/dt,evc) - end if - - b = sav-irc-shc-evc-tr+pahv !additional w/m2 - a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity - dtv = b/a - - irc = irc + fveg*4.*cir*tv**3*dtv - shc = shc + fveg*csh*dtv - evc = evc + fveg*cev*destv*dtv - tr = tr + fveg*ctr*destv*dtv - -! update vegetation surface temperature - tv = tv + dtv -! tah = ata + bta*tv ! canopy air t; update here for consistency - -! for computing m-o length in the next iteration - h = rhoair*cpair*(tah - sfctmp) /rahc - hg = rhoair*cpair*(tg - tah) /rahg - -! consistent specific humidity from canopy air vapor pressure - qsfc = (0.622*eah)/(sfcprs-0.378*eah) - - enddo ! iteration - endif ! sfcdiff3 - ! under-canopy fluxes and tg air = - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4 @@ -4443,7 +4248,8 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & #else tgb ,cm ,ch,ustarx, & !inout #endif - tauxb ,tauyb ,irb ,shb ,evb,csigmaf0,& !out + tauxb ,tauyb ,irb ,shb ,evb , & !out + csigmaf0, & !out ghb ,t2mb ,dx ,dz8w ,ivgtyp , & !out qc ,qsfc ,psfc , & !in sfcprs ,q2b ,ehb2 ) !in @@ -4489,14 +4295,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) real (kind=kind_phys), intent(in) :: fsno !snow fraction - logical , intent(in) :: thsfc_loc - real (kind=kind_phys) , intent(in) :: prslkix ! in exner function - real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function - real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function - real (kind=kind_phys) , intent(in) :: fveg - real (kind=kind_phys) , intent(in) :: shdfac - real (kind=kind_phys) , intent(in) :: garea1 - !jref:start; in integer , intent(in) :: ivgtyp real (kind=kind_phys) , intent(in) :: qc !cloud water mixing ratio @@ -4513,7 +4311,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(inout) :: tgb !ground temperature (k) real (kind=kind_phys), intent(inout) :: cm !momentum drag coefficient real (kind=kind_phys), intent(inout) :: ch !sensible heat exchange coefficient - real (kind=kind_phys), intent(inout) :: ustarx !friction velocity #ifdef CCPP character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -4529,7 +4326,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(out) :: evb !latent heat flux (w/m2) [+ to atm] real (kind=kind_phys), intent(out) :: ghb !ground heat flux (w/m2) [+ to soil] real (kind=kind_phys), intent(out) :: t2mb !2 m height air temperature (k) - real (kind=kind_phys), intent(out) :: csigmaf0 ! !jref:start real (kind=kind_phys), intent(out) :: q2b !bare ground heat conductance real (kind=kind_phys) :: ehb !bare ground heat conductance @@ -4540,17 +4336,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! local variables - real (kind=kind_phys) :: rb1b !Bulk Richardson # over bare soil - real (kind=kind_phys) :: stress1b !Stress over bare soil - real (kind=kind_phys) :: snwd - real (kind=kind_phys) :: virtfacb - real (kind=kind_phys) :: thv1b - real (kind=kind_phys) :: tvsb - real (kind=kind_phys) :: tv1b - real (kind=kind_phys) :: zlvlb - - real (kind=kind_phys) :: fm10 - real (kind=kind_phys) :: taux !wind stress: e-w (n/m2) real (kind=kind_phys) :: tauy !wind stress: n-s (n/m2) real (kind=kind_phys) :: fira !total net longwave rad (w/m2) [+ to atm] @@ -4577,9 +4362,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: cev !coefficients for ev as function of esat[ts] real (kind=kind_phys) :: cgh !coefficients for st as function of ts - real(kind=kind_phys) :: kbsigmaf0 - real(kind=kind_phys) :: reynb - !jref:start real (kind=kind_phys) :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m) real (kind=kind_phys) :: rawb2 !aerodynamic resistance for water vapor 2m (s/m) @@ -4614,18 +4396,26 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: fh2 !monin-obukhov heat adjustment at 2m real (kind=kind_phys) :: ch2 !surface exchange at 2m - real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx,czil1 - real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 - integer :: iter !iteration index integer :: niterb !number of iterations for surface temperature - integer :: niter - real (kind=kind_phys) :: mpe !prevents overflow error if division by zero !jref:start ! data niterb /3/ data niterb /5/ save niterb + +! New variables for sfcdif3 + + logical , intent(in ) :: thsfc_loc + real (kind=kind_phys), intent(in ) :: prslkix ! in exner function + real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function + real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function + real (kind=kind_phys), intent(in ) :: fveg + real (kind=kind_phys), intent(in ) :: shdfac + real (kind=kind_phys), intent(in ) :: garea1 + real (kind=kind_phys), intent(inout) :: ustarx !friction velocity + real (kind=kind_phys), intent( out) :: csigmaf0 ! + real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 tdc(t) = min( 50., max(-50.,(t-tfrz)) ) @@ -4641,69 +4431,10 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & h = 0. qfx = 0. - csigmaf0 = 0. - kbsigmaf0 = 0. - - niter = 1 - if (ur < 2.0) niter = 2 - - fv = ustarx - -! fv = ur*vkc/log((zlvl-zpd)/z0m) - - reynb = fv*z0m/(1.5e-05) - - if (reynb .gt. 2.0) then - kbsigmaf0 = 2.46*reynb**0.25 - log(7.4) - else - kbsigmaf0 = - log(0.397) - endif - - csigmaf0 = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf0) - - if (opt_trs == 1) then - z0h = z0m - elseif (opt_trs == 2) then -! z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) - czil1= 10.0 ** (- (0.40/0.07) * parameters%hvt) - z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) - elseif (opt_trs == 3) then - if (vegtyp.le.5) then - z0h = z0m - else - z0h = z0m*0.01 - endif - elseif (opt_trs == 4) then - z0h = max(z0m/exp(kbsigmaf0),1.0e-6) - endif -! -! for sfcdiff3; maybe should move to inside the option -! - snwd = snowh*1000.0 -! zlvlb = zlvl - zpd - zlvlb = zlvl - - virtfacb = 1.0 + 0.61 * max(qair, 1.e-8) - tv1b = sfctmp * virtfacb - - if(thsfc_loc) then ! Use local potential temperature - thv1b = sfctmp * prslkix * virtfacb - else ! Use potential temperature reference to 1000 hPa - thv1b = sfctmp / prslk1x * virtfacb - endif - cir = emg*sb cgh = 2.*df(isnow+1)/dzsnso(isnow+1) ! ----------------------------------------------------------------- - tem1 = (z0m - z0lo) / (z0up - z0lo) - tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(shdfac, 0.1_kind_phys) - zvfun1= sqrt(tem1 * tem2) - gdx=sqrt(garea1) - - if (opt_sfc == 1 .or. opt_sfc == 2) then - loop3: do iter = 1, niterb ! begin stability iteration ! if(iter == 1) then @@ -4743,6 +4474,15 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & endif + if(opt_sfc == 3) then + call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in + zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in + zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 , & !in + ustarx ,fm ,fh ,fm2 ,fh2 , & !inout + z0h ,fv ,csigmaf0,cm ,ch ) !out + + endif + ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) rawb = rahb @@ -4800,83 +4540,8 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & qfx = (qsfc-qair)*cev*gamma/cpair end do loop3 ! end stability iteration - endif ! opt_sfc 1/2 ! ----------------------------------------------------------------- - if (opt_sfc == 3) then - - do iter = 1, niter !1 or 2; depending on ur - - if(thsfc_loc) then ! Use local potential temperature - tvsb = tgb * virtfacb - else ! Use potential temperature referenced to 1000 hPa - tvsb = tgb/prsik1x * virtfacb - endif - - call stability & - (zlvlb, zvfun1, gdx,tv1b,thv1b, ur, z0m, z0h, tvsb, grav,thsfc_loc, & - rb1b, fm,fh,fm10,fh2,cm,ch,stress1b,fv) - - - ramb = max(1.,1./(cm*ur)) - rahb = max(1.,1./(ch*ur)) - rawb = rahb - -!jref - variables for diagnostics - emb = 1./ramb - ehb = 1./rahb - -! es and d(es)/dt evaluated at tg - - t = tdc(tgb) - call esat(t, esatw, esati, dsatw, dsati) - if (t .gt. 0.) then - estg = esatw - destg = dsatw - else - estg = esati - destg = dsati - end if - - csh = rhoair*cpair/rahb - cev = rhoair*cpair/gamma/(rsurf+rawb) - -! surface fluxes and dtg - - irb = cir * tgb**4 - emg*lwdn - shb = csh * (tgb - sfctmp ) - evb = cev * (estg*rhsur - eair ) - ghb = cgh * (tgb - stc(isnow+1)) - - b = sag-irb-shb-evb-ghb+pahb - a = 4.*cir*tgb**3 + csh + cev*destg + cgh - dtg = b/a - - irb = irb + 4.*cir*tgb**3*dtg - shb = shb + csh*dtg - evb = evb + cev*destg*dtg - ghb = ghb + cgh*dtg - -! update ground surface temperature - tgb = tgb + dtg - -! for m-o length -! h = csh * (tgb - sfctmp) - - t = tdc(tgb) - call esat(t, esatw, esati, dsatw, dsati) - if (t .gt. 0.) then - estg = esatw - else - estg = esati - end if - qsfc = 0.622*(estg*rhsur)/(psfc-0.378*(estg*rhsur)) - - qfx = (qsfc-qair)*cev*gamma/cpair - - end do ! end stability iteration - endif ! sfcdiff3 - ! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. if(opt_stc == 1 .or. opt_stc == 3) then @@ -5409,6 +5074,126 @@ subroutine sfcdif2(parameters,iter ,z0 ,thz0 ,thlm ,sfcspd , & !in ! ---------------------------------------------------------------------- end subroutine sfcdif2 +!== begin sfcdif3 ================================================================================== + +!>\ingroup NoahMP_LSM +!! compute surface drag coefficient cm for momentum and ch for heat. + subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in + zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie , & !in + ustarx ,fm ,fh ,fm2 ,fh2 , & !inout + z0h ,fv ,csigmaf ,cm ,ch ) !out + +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient cm for momentum and ch for heat +! ------------------------------------------------------------------------------------------------- + implicit none +! ------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in ) :: iloc ! grid index + integer, intent(in ) :: jloc ! grid index + integer, intent(in ) :: iter ! iteration index + real (kind=kind_phys), intent(in ) :: sfctmp ! temperature at reference height [K] + real (kind=kind_phys), intent(in ) :: qair ! specific humidity at reference height [kg/kg] + real (kind=kind_phys), intent(in ) :: ur ! wind speed [m/s] + real (kind=kind_phys), intent(in ) :: zlvl ! reference height [m] + real (kind=kind_phys), intent(in ) :: tgb ! ground temperature [K] + logical, intent(in ) :: thsfc_loc ! flag for using sfc-based theta + real (kind=kind_phys), intent(in ) :: prslkix ! in exner function + real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function + real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function + real (kind=kind_phys), intent(in ) :: z0m ! roughness length, momentum, ground [m] + real (kind=kind_phys), intent(in ) :: zpd ! zero plane displacement [m] + real (kind=kind_phys), intent(in ) :: snowh ! snow depth [m] + real (kind=kind_phys), intent(in ) :: fveg ! fractional vegetation cover + real (kind=kind_phys), intent(in ) :: garea1 ! grid area [km2] + logical, intent(in ) :: vegetated ! .true. if vegetated + real (kind=kind_phys), intent(in ) :: vaie ! vegetation area index [m2/m2] + real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity [m/s] + real (kind=kind_phys), intent(inout) :: fm ! momentum stability correction, weighted by prior iters + real (kind=kind_phys), intent(inout) :: fh ! sen heat stability correction, weighted by prior iters + real (kind=kind_phys), intent(inout) :: fm2 ! sen heat stability correction, weighted by prior iters + real (kind=kind_phys), intent(inout) :: fh2 ! sen heat stability correction, weighted by prior iters + real (kind=kind_phys), intent( out) :: z0h ! roughness length, sensible heat, ground [m] + real (kind=kind_phys), intent( out) :: fv ! friction velocity (m/s) + real (kind=kind_phys), intent( out) :: csigmaf ! + real (kind=kind_phys), intent( out) :: cm ! drag coefficient for momentum + real (kind=kind_phys), intent( out) :: ch ! drag coefficient for heat + + real (kind=kind_phys) :: reyn ! reynolds number + real (kind=kind_phys) :: kbsigmaf ! kb factor + real (kind=kind_phys) :: snwd ! snow depth [mm] + real (kind=kind_phys) :: zlvlb ! reference height - zpd [m] + real (kind=kind_phys) :: virtfac ! virtual temperature factor [-] + real (kind=kind_phys) :: tv1 ! virtual temperature at reference [K] + real (kind=kind_phys) :: thv1 ! virtual theta at reference [K] + real (kind=kind_phys) :: tvs ! virtural surface temperature [K] + real (kind=kind_phys) :: rb1 ! bulk Richardson - stability output + real (kind=kind_phys) :: stress1 ! stress - stability output + real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output + real (kind=kind_phys) :: dlf ! leaf dimension + real (kind=kind_phys) :: sigmaa ! momentum partition parameter + real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx + real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 + +! ------------------------------------------------------------------------------------------------- + + fv = ustarx +! fv = ur*vkc/log((zlvl-zpd)/z0m) + + if(vegetated) then + + dlf = parameters%dleaf + sigmaa = 1.0 - (0.5/(0.5+vaie)) * exp(-vaie**2/8.0) + kbsigmaf = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) + z0h = z0m/exp(kbsigmaf) + csigmaf = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf) ! for output for interpolation + + else + + reyn = fv*z0m/(1.5e-05) + if (reyn .gt. 2.0) then + kbsigmaf = 2.46*reyn**0.25 - log(7.4) + else + kbsigmaf = - log(0.397) + endif + + z0h = max(z0m/exp(kbsigmaf),1.0e-6) + csigmaf = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf) + + end if + + snwd = snowh*1000.0 + zlvlb = zlvl! - zpd + + virtfac = 1.0 + 0.61 * max(qair, 1.0e-8) + tv1 = sfctmp * virtfac + + if(thsfc_loc) then ! Use local potential temperature + thv1 = sfctmp * prslkix * virtfac + else ! Use potential temperature reference to 1000 hPa + thv1 = sfctmp / prslk1x * virtfac + endif + + tem1 = (z0m - z0lo) / (z0up - z0lo) + tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) + tem2 = max(fveg, 0.1_kind_phys) + zvfun1 = sqrt(tem1 * tem2) + gdx = sqrt(garea1) + + if(thsfc_loc) then ! Use local potential temperature + tvs = tgb * virtfac + else ! Use potential temperature referenced to 1000 hPa + tvs = tgb/prsik1x * virtfac + endif + + call stability (zlvlb, zvfun1, gdx, tv1, thv1, ur, z0m, z0h, tvs, grav, thsfc_loc, & + rb1, fm,fh,fm10,fh2,cm,ch,stress1,fv) + + end subroutine sfcdif3 + !== begin esat ===================================================================================== !>\ingroup NoahMP_LSM From c50f50a07c78e9eed773f8c936d8360b61a1d5c9 Mon Sep 17 00:00:00 2001 From: barlage Date: Mon, 7 Mar 2022 14:42:58 -0700 Subject: [PATCH 089/217] change fveg to shdfac in sfcdif3 vege call --- physics/module_sf_noahmplsm.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 0248a116b..5964e4575 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4017,7 +4017,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,.true. ,vaie , & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out From 53c0c7acfe64609c021e551f1edf67376bcd1387 Mon Sep 17 00:00:00 2001 From: barlage Date: Mon, 7 Mar 2022 15:07:35 -0700 Subject: [PATCH 090/217] move trs options to sfcdif3 --- physics/module_sf_noahmplsm.f90 | 44 ++++++++++++++++++++++++++------- 1 file changed, 35 insertions(+), 9 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 5964e4575..42a213fed 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -3986,6 +3986,19 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & z0hg = z0mg !* exp(-czil*0.4*258.2*sqrt(fv*z0mg)) end if + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + czil1= 10.0 ** (- (0.40/0.07) * parameters%hvt) + z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0h = z0m + else + z0h = z0m*0.01 + endif + endif + ! aerodyn resistances between heights zlvl and d+z0v if(opt_sfc == 1) then @@ -4017,7 +4030,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie , & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out @@ -4477,7 +4490,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 , & !in + zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 ,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out @@ -5080,7 +5093,7 @@ end subroutine sfcdif2 !! compute surface drag coefficient cm for momentum and ch for heat. subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,vegetated,vaie , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie ,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf ,cm ,ch ) !out @@ -5111,6 +5124,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys), intent(in ) :: garea1 ! grid area [km2] logical, intent(in ) :: vegetated ! .true. if vegetated real (kind=kind_phys), intent(in ) :: vaie ! vegetation area index [m2/m2] + integer , intent(in ) :: vegtyp ! vegetation category real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity [m/s] real (kind=kind_phys), intent(inout) :: fm ! momentum stability correction, weighted by prior iters real (kind=kind_phys), intent(inout) :: fh ! sen heat stability correction, weighted by prior iters @@ -5132,8 +5146,8 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys) :: tvs ! virtural surface temperature [K] real (kind=kind_phys) :: rb1 ! bulk Richardson - stability output real (kind=kind_phys) :: stress1 ! stress - stability output + real (kind=kind_phys) :: czil1 ! canopy based czil real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output - real (kind=kind_phys) :: dlf ! leaf dimension real (kind=kind_phys) :: sigmaa ! momentum partition parameter real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 @@ -5145,11 +5159,23 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur if(vegetated) then - dlf = parameters%dleaf - sigmaa = 1.0 - (0.5/(0.5+vaie)) * exp(-vaie**2/8.0) - kbsigmaf = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) - z0h = z0m/exp(kbsigmaf) - csigmaf = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf) ! for output for interpolation + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + czil1= 10.0 ** (- (0.40/0.07) * parameters%hvt) + z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0h = z0m + else + z0h = z0m*0.01 + endif + elseif (opt_trs == 4) then + sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) + kbsigmaf = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(parameters%dleaf*ur/log((zlvl-zpd)/z0m)) + z0h = z0m/exp(kbsigmaf) + csigmaf = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m)+kbsigmaf) ! for output for interpolation + endif else From f093f77d40f4d7e0c5097caa20191050964ef5d5 Mon Sep 17 00:00:00 2001 From: barlage Date: Mon, 7 Mar 2022 15:10:50 -0700 Subject: [PATCH 091/217] fix missing czil1 in vege_flux --- physics/module_sf_noahmplsm.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 42a213fed..4a296debb 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -3887,6 +3887,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in ) :: shdfac ! greeness vegetation fraction (-) real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity real (kind=kind_phys), intent( out) :: csigmaf1 ! + real (kind=kind_phys) :: czil1 ! canopy based czil real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 From 4a4d1598ac958d0c95604091973a5fe3c32c7435 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 7 Mar 2022 23:44:37 +0000 Subject: [PATCH 092/217] Bug fix --- physics/GFS_rrtmgp_cloud_mp.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 1108818d9..d9e796f88 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -397,8 +397,8 @@ subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum do iCol = 1, nCol if (cld_mynn_frac(iCol,iLay) > cld_limit_lower) then ! Cloud mixing-ratios - qc = qc_mynn(i,k)*cld_mynn_frac(iCol,iLay) - qi = qi_mynn(i,k)*cld_mynn_frac(iCol,iLay) + qc = qc_mynn(iCol,iLay)*cld_mynn_frac(iCol,iLay) + qi = qi_mynn(iCol,iLay)*cld_mynn_frac(iCol,iLay) ! LWP/IWP deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. From 386244dc9936b69c2127e4cfb5c1bb67b7b5bebd Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Tue, 8 Mar 2022 05:12:15 +0000 Subject: [PATCH 093/217] Implement support for coupled air quality systems (AQM/CMAQ) in generic physics code for PBL and surface schemes using the 'cplaqm' logical variable. --- physics/GFS_PBL_generic.F90 | 27 +++++++++++++++++++++++++-- physics/GFS_PBL_generic.meta | 7 +++++++ physics/GFS_surface_generic.F90 | 32 ++++++++++++++++++++++++++++++-- physics/GFS_surface_generic.meta | 7 +++++++ 4 files changed, 69 insertions(+), 4 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 5bbbefe52..5c14e5ff7 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -329,7 +329,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, trans_aero, ntchs, ntchm, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, imp_physics_mg, & imp_physics_fer_hires, & - ltaerosol, cplflx, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, & + ltaerosol, cplflx, cplaqm, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, & shinhong, do_ysu, dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, & dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & index_of_process_pbl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, & @@ -349,7 +349,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires - logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, lsidea + logical, intent(in) :: ltaerosol, cplflx, cplaqm, cplchm, lssav, ldiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu logical, intent(in) :: flag_for_pbl_generic_tend @@ -619,6 +619,29 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, end if end if + if (cplaqm .and. .not.cplflx) then + do i=1,im + if (oceanfrac(i) > zero) then ! Ocean only, NO LAKES + if ( .not. wet(i)) then ! no open water + if (kdt > 1) then !use results from CICE + dtsfci_cpl(i) = dtsfc_cice(i) + dqsfci_cpl(i) = dqsfc_cice(i) + else !use PBL fluxes when CICE fluxes is unavailable + dtsfci_cpl(i) = dtsfc1(i)*hffac(i) + dqsfci_cpl(i) = dqsfc1(i) + end if + elseif (icy(i) .or. dry(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point + rho = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) + dtsfci_cpl(i) = cp * rho * hflx_wat(i) ! sensible heat flux over open ocean + dqsfci_cpl(i) = hvap * rho * evap_wat(i) ! latent heat flux over open ocean + else ! use results from PBL scheme for 100% open ocean + dtsfci_cpl(i) = dtsfc1(i)*hffac(i) + dqsfci_cpl(i) = dqsfc1(i) + endif + endif ! Ocean only, NO LAKES + enddo + end if + !-------------------------------------------------------lssav if loop ---------- if (lssav) then do i=1,im diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 27c659c2c..0df41369e 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -616,6 +616,13 @@ dimensions = () type = logical intent = in +[cplaqm] + standard_name = flag_for_air_quality_coupling + long_name = flag controlling cplaqm collection (default off) + units = flag + dimensions = () + type = logical + intent = in [cplchm] standard_name = flag_for_chemistry_coupling long_name = flag controlling cplchm collection (default off) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 1b39409b3..aecc6fcf7 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -274,7 +274,7 @@ end subroutine GFS_surface_generic_post_finalize !> \section arg_table_GFS_surface_generic_post_run Argument Table !! \htmlinclude GFS_surface_generic_post_run.html !! - subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, icy, wet, & + subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, lssav, dry, icy, wet, & lsm, lsm_noahmp, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, & adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, & adjvisbmu, adjvisdfu, t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, pah, pahi, & @@ -288,7 +288,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, implicit none integer, intent(in) :: im - logical, intent(in) :: cplflx, cplchm, cplwav, lssav + logical, intent(in) :: cplflx, cplaqm, cplchm, cplwav, lssav logical, dimension(:), intent(in) :: dry, icy, wet integer, intent(in) :: lsm, lsm_noahmp real(kind=kind_phys), intent(in) :: dtf @@ -416,6 +416,34 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, enddo endif + if (cplaqm .and. .not.cplflx) then + do i=1,im + t2mi_cpl (i) = t2m(i) + q2mi_cpl (i) = q2m(i) + psurfi_cpl (i) = pgr(i) + if (wet(i)) then ! some open water +! --- compute open water albedo + xcosz_loc = max( zero, min( one, xcosz(i) )) + ocalnirdf_cpl = 0.06_kind_phys + ocalnirbm_cpl = max(albdf, 0.026_kind_phys/(xcosz_loc**1.7_kind_phys+0.065_kind_phys) & + & + 0.15_kind_phys * (xcosz_loc-0.1_kind_phys) * (xcosz_loc-0.5_kind_phys) & + & * (xcosz_loc-one)) + ocalvisdf_cpl = 0.06_kind_phys + ocalvisbm_cpl = ocalnirbm_cpl + + nswsfci_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl) + & + adjnirdfd(i) * (one-ocalnirdf_cpl) + & + adjvisbmd(i) * (one-ocalvisbm_cpl) + & + adjvisdfd(i) * (one-ocalvisdf_cpl) + else + nswsfci_cpl(i) = adjnirbmd(i) - adjnirbmu(i) + & + adjnirdfd(i) - adjnirdfu(i) + & + adjvisbmd(i) - adjvisbmu(i) + & + adjvisdfd(i) - adjvisdfu(i) + endif + enddo + endif + if (lssav) then do i=1,im gflux(i) = gflux(i) + gflx(i) * dtf diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 6ad2953a6..d40c7251a 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -558,6 +558,13 @@ dimensions = () type = logical intent = in +[cplaqm] + standard_name = flag_for_air_quality_coupling + long_name = flag controlling cplaqm collection (default off) + units = flag + dimensions = () + type = logical + intent = in [cplchm] standard_name = flag_for_chemistry_coupling long_name = flag controlling cplchm collection (default off) From 13a1d1480410c3c7b453e252f2d3c159e48cb04f Mon Sep 17 00:00:00 2001 From: barlage Date: Tue, 8 Mar 2022 06:55:33 -0700 Subject: [PATCH 094/217] add some clean up to energy --- physics/module_sf_noahmplsm.f90 | 65 +++++++++++++++++---------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 4a296debb..4ff484dfb 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -1952,26 +1952,21 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in chv2 = 0. rb = 0. -! - cdmnv = 0. - ezpdv = 0. - - cdmng = 0. - ezpdg = 0. - - cdmn = 0. - ezpd = 0. - - gsigma = 0. - - z0hwrf = 0. - csigmaf1 = 0. - csigmaf0 = 0. - csigmafveg= 0. - kbsigmafveg = 0. - aone = 0. - coeffa = 0. - coeffb = 0. + cdmnv = 0.0 + ezpdv = 0.0 + cdmng = 0.0 + ezpdg = 0.0 + cdmn = 0.0 + ezpd = 0.0 + gsigma = 0.0 + z0hwrf = 0.0 + csigmaf1 = 0.0 + csigmaf0 = 0.0 + csigmafveg= 0.0 + kbsigmafveg = 0.0 + aone = 0.0 + coeffa = 0.0 + coeffb = 0.0 ! @@ -2190,9 +2185,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in qc ,qsfc ,psfc , & !in q2v ,chv2, chleaf, chuc) !inout - cdmnv = 0.4*0.4/log((zlvl-zpd)/z0m)**2 - aone = 2.6*(10.0*parameters%hvt/(zlvl-zpd))**0.355 - ezpdv = zpd*fveg !for the grid +! new coupling code + + cdmnv = 0.4*0.4/log((zlvl-zpd)/z0m)**2 + aone = 2.6*(10.0*parameters%hvt/(zlvl-zpd))**0.355 + ezpdv = zpd*fveg !for the grid !jref:end #ifdef CCPP @@ -2221,18 +2218,20 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in qc ,qsfc ,psfc , & !in sfcprs ,q2b, chb2) !in - cdmng = 0.4*0.4/log((zlvl-zpdg)/z0mg)**2 - ezpdg = zpdg +! new coupling code + + cdmng = 0.4*0.4/log((zlvl-zpdg)/z0mg)**2 + ezpdg = zpdg ! ! vegetation is optional; use the larger one ! - if (ezpdv .ge. ezpdg ) then - ezpd = ezpdv - elseif (ezpdv .gt. 0.0 .and. ezpdv .lt. ezpdg) then - ezpd = (1.0 -fveg)*ezpdg - else - ezpd = ezpdg - endif + if (ezpdv .ge. ezpdg ) then + ezpd = ezpdv + elseif (ezpdv .gt. 0.0 .and. ezpdv .lt. ezpdg) then + ezpd = (1.0 -fveg)*ezpdg + else + ezpd = ezpdg + endif !jref:end #ifdef CCPP @@ -2260,6 +2259,8 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc q2e = fveg * q2v + (1.0 - fveg) * q2b +! new coupling code + if (opt_trs == 1) then z0wrf = fveg * z0m + (1.0 - fveg) * z0mg z0hwrf = z0wrf From ebb4fa16d3d2494850431a97b3772e60875d8975 Mon Sep 17 00:00:00 2001 From: barlage Date: Tue, 8 Mar 2022 07:01:12 -0700 Subject: [PATCH 095/217] add some groundwater mods from ncar code --- physics/module_sf_noahmplsm.f90 | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 4ff484dfb..445034741 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -7621,8 +7621,10 @@ subroutine soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in if ( parameters%urban_flag ) fcr(1)= 0.95 if(opt_run == 1) then - fff = 6.0 - fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0)) +! fff = 6.0 + fff = parameters%bexp(1) / 3.0 ! calibratable, c.he changed based on gy niu's update +! fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0)) + fsat = parameters%fsatmx*exp(-0.5*fff*zwt) ! c.he changed based on gy niu's update if(qinsur > 0.) then runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) pddum = qinsur - runsrf ! m/s @@ -8337,8 +8339,9 @@ subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in real (kind=kind_phys) :: watmin!minimum soil vol soil moisture [m3/m3] real (kind=kind_phys) :: xs !excessive water above saturation [mm] real (kind=kind_phys), parameter :: rous = 0.2 !specific yield [-] - real (kind=kind_phys), parameter :: cmic = 0.20 !microprore content (0.0-1.0) +! real (kind=kind_phys), parameter :: cmic = 0.20 !microprore content (0.0-1.0) !0.0-close to free drainage + real (kind=kind_phys), parameter :: cmic = 0.80 ! calibratable, c.he changed based on gy niu's update ! ------------------------------------------------------------- qdis = 0.0 qin = 0.0 @@ -8380,8 +8383,10 @@ subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in ! groundwater discharge [mm/s] - fff = 6.0 - rsbmx = 5.0 +! fff = 6.0 +! rsbmx = 5.0 + fff = parameters%bexp(iwt) / 3.0 ! calibratable, c.he changed based on gy niu's update + rsbmx = hk(iwt) * 1.0e3 * exp(3.0) ! mm/s, calibratable, c.he changed based on gy niu's update qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*(zwt-2.0)) From 41cf4ecb44a6a983a8132c2986b91a0c2964595b Mon Sep 17 00:00:00 2001 From: helin wei Date: Tue, 8 Mar 2022 14:31:07 +0000 Subject: [PATCH 096/217] gvf impact on thermal conductivity limited to the first soil layer --- physics/module_sf_noahmplsm.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 4a296debb..0601e98f1 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -2503,7 +2503,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) - df = df * exp (sbeta * fveg) + df(1) = df(1) * exp (sbeta * fveg) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) From c1d813e21bd5238c65c95974264965e2f01540f6 Mon Sep 17 00:00:00 2001 From: helin wei Date: Tue, 8 Mar 2022 19:19:40 +0000 Subject: [PATCH 097/217] correct the reference height --- physics/module_sf_noahmp_glacier.f90 | 3 +-- physics/module_sf_noahmplsm.f90 | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index 1ea4a45b8..c4c03aaf8 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -1152,8 +1152,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! the following only applies to opt_sfc =3, opt_sfc = 1 still done its old way snwd = snowh*1000.0 -! zlvli = zlvl - zpd - zlvli = zlvl + zlvli = zlvl - zpd ! fv = ustarx ! the input maybe too high for glacial fv = ur*vkc/log(zlvli/z0m) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index a93284475..919d81507 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -5194,7 +5194,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur end if snwd = snowh*1000.0 - zlvlb = zlvl! - zpd + zlvlb = zlvl - zpd virtfac = 1.0 + 0.61 * max(qair, 1.0e-8) tv1 = sfctmp * virtfac From be960f09b5ba02b00e3711c42fbfa31bafbd8fe4 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 8 Mar 2022 21:41:23 +0000 Subject: [PATCH 098/217] Added switches for sgs clouds in GP. --- physics/GFS_rrtmgp_cloud_mp.F90 | 103 ++++++++++++++++++++++++-------- physics/rrtmgp_lw_rte.F90 | 12 ++-- physics/rrtmgp_lw_rte.meta | 28 +++------ physics/rrtmgp_sw_rte.F90 | 12 ++-- physics/rrtmgp_sw_rte.meta | 34 ++++------- 5 files changed, 106 insertions(+), 83 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index d9e796f88..8d01b05e4 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -39,15 +39,16 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, kdt, & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, doSWrad, doLWrad, effr_in, lmfshal, & ltaerosol, icloud, imp_physics, imp_physics_thompson, imp_physics_gfdl, & - lgfdlmprad, do_mynnedmf, uni_cld, lmfdeep2, p_lev, p_lay, t_lay, & - qs_lay, q_lay, relhum, lsmask, xlon, xlat, dx, tv_lay, effrin_cldliq, & - effrin_cldice, effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cld_cnv_frac,& - qci_conv, deltaZ, deltaZc, deltaP, qc_mynn, qi_mynn, cld_mynn_frac, con_g, con_rd,& - con_eps, con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, & - cld_mynn_lwp, cld_mynn_reliq, cld_mynn_iwp, cld_mynn_reice, lwp_ex, iwp_ex, & - lwp_fc, iwp_fc, errmsg, errflg) + lgfdlmprad, do_mynnedmf, uni_cld, lmfdeep2, p_lev, p_lay, t_lay, qs_lay, q_lay, & + relhum, lsmask, xlon, xlat, dx, tv_lay, effrin_cldliq, effrin_cldice, & + effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cld_cnv_frac, qci_conv, & + deltaZ, deltaZc, deltaP, qc_mynn, qi_mynn, cld_mynn_frac, con_g, con_rd, con_eps, & + con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, cld_frac, cld_lwp, cld_reliq, & + cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & + cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_mynn_lwp, & + cld_mynn_reliq, cld_mynn_iwp, cld_mynn_reice, lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + errmsg, errflg) + implicit none ! Inputs integer, intent(in) :: & @@ -164,6 +165,7 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic ! ################################################################################### ! GFDL Microphysics + ! ("Implicit" SGS cloud-coupling to the radiation) ! ################################################################################### if (imp_physics == imp_physics_gfdl) then ! GFDL-Lin @@ -214,6 +216,7 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic ! ################################################################################### ! Thompson Microphysics + ! ("Explicit" SGS cloud-coupling to the radiation) ! ################################################################################### if (imp_physics == imp_physics_thompson) then @@ -226,15 +229,17 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic ! Grell-Freitas convective clouds? if (imfdeepcnv == imfdeepcnv_gf) then + alpha0 = 100. call cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & - qci_conv, con_ttp, con_g, & + qci_conv, con_ttp, con_g, alpha0, & cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_cnv_frac) endif ! SAMF scale & aerosol-aware mass-flux convective clouds? if (imfdeepcnv == imfdeepcnv_samf) then + alpha0 = 200. call cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, & - cnv_mixratio, con_ttp, con_g, & + cnv_mixratio, con_ttp, con_g, alpha0, & cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_cnv_frac) endif @@ -247,7 +252,7 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic cld_resnow = effrin_cldsnow ! Thomson MP using modified Xu-Randall cloud-fraction (additionally conditioned on RH) - alpha0 = 200. + alpha0 = 2000. call cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, & relhum, con_g, con_rd, con_eps, alpha0, lwp_ex, iwp_ex, lwp_fc, iwp_fc, & @@ -286,7 +291,8 @@ subroutine GFS_rrtmgp_cloud_mp_finalize() end subroutine GFS_rrtmgp_cloud_mp_finalize ! ###################################################################################### - ! Compute cloud radiative properties for Grell-Freitas convective cloud scheme + ! Compute cloud radiative properties for Grell-Freitas convective cloud scheme. + ! (Adopted from module_SGSCloud_RadPre) ! ! - The total convective cloud condensate is partitoned by phase, using temperature, into ! liquid/ice convective cloud mixing-ratios. Compute convective cloud LWP and IWP's. @@ -294,12 +300,17 @@ end subroutine GFS_rrtmgp_cloud_mp_finalize ! - The liquid and ice cloud effective particle sizes are assigned reference values*. ! *TODO* Find references, include DOIs, parameterize magic numbers, etc... ! - ! - The convective cloud-fraction is computed using Xu-Randall (1996). + ! - The convective cloud-fraction is computed using Xu-Randall (1996). + ! (DJS asks: Does the GF scheme produce a cloud-fraction? If so, maybe use instead of + ! Xu-Randall? Xu-Randall is consistent with the Thompson MP scheme, but + ! not GFDL-EMC) ! ! ###################################################################################### subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & - qci_conv, con_ttp, con_g, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, & - cld_cnv_frac) + qci_conv, con_ttp, con_g, alpha0, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & + cld_cnv_reice, cld_cnv_frac) + implicit none + ! Inputs integer, intent(in) :: & nCol, & ! Number of horizontal grid points @@ -308,7 +319,8 @@ subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, lsmask ! Land/Sea mask real(kind_phys), intent(in) :: & con_g, & ! Physical constant: gravitational constant - con_ttp ! Triple point temperature of water (K) + con_ttp, & ! Triple point temperature of water (K) + alpha0 ! real(kind_phys), dimension(:,:),intent(in) :: & t_lay, & ! Temperature at layer centers (K) p_lev, & ! Pressure at layer interfaces (Pa) @@ -326,7 +338,6 @@ subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, ! Local integer :: iCol, iLay real(kind_phys) :: tem1, deltaP, clwc, qc, qi - real(kind_phys), parameter :: alpha0=100 do iLay = 1, nLev do iCol = 1, nCol @@ -360,10 +371,21 @@ subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, end subroutine cloud_mp_GF ! ###################################################################################### + ! Compute cloud radiative properties for MYNN-EDMF PBL cloud scheme. + ! (Adopted from module_SGSCloud_RadPre) + ! + ! - Cloud-fraction, liquid, and ice condensate mixing-ratios from MYNN-EDMF cloud scheme + ! are provided as inputs. Cloud LWP and IWP are computed. + ! + ! - The liquid and ice cloud effective particle sizes are assigned reference values*. + ! *TODO* Find references, include DOIs, parameterize magic numbers, etc... + ! ! ###################################################################################### subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & qc_mynn, qi_mynn, con_ttp, con_g, cld_mynn_lwp, cld_mynn_reliq, cld_mynn_iwp, & cld_mynn_reice, cld_mynn_frac) + implicit none + ! Inputs integer, intent(in) :: & nCol, & ! Number of horizontal grid points @@ -396,7 +418,7 @@ subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum do iLay = 1, nLev do iCol = 1, nCol if (cld_mynn_frac(iCol,iLay) > cld_limit_lower) then - ! Cloud mixing-ratios + ! Cloud mixing-ratios (DJS asks: Why is this done?) qc = qc_mynn(iCol,iLay)*cld_mynn_frac(iCol,iLay) qi = qi_mynn(iCol,iLay)*cld_mynn_frac(iCol,iLay) @@ -421,17 +443,30 @@ subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum end subroutine cloud_mp_MYNN ! ###################################################################################### + ! Compute cloud radiative properties for SAMF convective cloud scheme. + ! + ! - The total-cloud convective mixing-ratio is partitioned by phase into liquid/ice + ! cloud properties. LWP and IWP are computed. + ! + ! - The liquid and ice cloud effective particle sizes are assigned reference values. + ! + ! - The convective cloud-fraction is computed using Xu-Randall (1996). + ! (DJS asks: Does the SAMF scheme produce a cloud-fraction?) + ! ! ###################################################################################### subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, & - cnv_mixratio, con_ttp, con_g, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & + cnv_mixratio, con_ttp, con_g, alpha0, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & cld_cnv_reice, cld_cnv_frac) + implicit none + ! Inputs integer, intent(in) :: & nCol, & ! Number of horizontal grid points nLev ! Number of vertical layers real(kind_phys), intent(in) :: & con_g, & ! Physical constant: gravitational constant - con_ttp ! Triple point temperature of water (K) + con_ttp, & ! Triple point temperature of water (K) + alpha0 ! real(kind_phys), dimension(:,:),intent(in) :: & t_lay, & ! Temperature at layer centers (K) p_lev, & ! Pressure at layer interfaces (Pa) @@ -449,7 +484,6 @@ subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, ! Local integer :: iCol, iLay real(kind_phys) :: tem1, deltaP, clwc - real(kind_phys), parameter :: alpha0=200 do iLay = 1, nLev do iCol = 1, nCol @@ -472,6 +506,14 @@ subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, end subroutine cloud_mp_SAMF ! ###################################################################################### + ! This routine computes the cloud radiative properties for a "unified cloud". + ! + ! - "unified cloud" implies that the cloud-fraction is PROVIDED. + ! + ! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. + ! + ! - If particle sizes are provided, they are used. If not, default values are assigned. + ! ! ###################################################################################### subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, p_lev, p_lay, t_lay, tv_lay,& @@ -599,6 +641,17 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai end subroutine cloud_mp_uni ! ###################################################################################### + ! This routine computes the cloud radiative properties for the Thompson cloud micro- + ! physics scheme. + ! + ! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. + ! + ! - There are no assumptions about particle size applied here. Effective particle sizes + ! are updated prior to this routine, see cmp_reff_Thompson(). + ! + ! - The cloud-fraction is computed using Xu-Randall** (1996). + ! **Additionally, Conditioned on relative-humidity** + ! ! ###################################################################################### subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, relhum, & @@ -719,7 +772,7 @@ end subroutine cloud_mp_thompson ! ! ###################################################################################### function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) - + implicit none ! Inputs real(kind_phys), intent(in) :: & p_lay, & ! Pressure (Pa) @@ -755,11 +808,13 @@ function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) end function ! ###################################################################################### + ! This routine is a wrapper to update the Thompson effective particle sizes used by the + ! RRTMGP radiation scheme. + ! ! ###################################################################################### subroutine cmp_reff_Thompson(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & i_cldliq_nc, i_twa, q_lay, p_lay, t_lay, tracer, con_eps, con_rd, ltaerosol, & effrin_cldliq, effrin_cldice, effrin_cldsnow) - implicit none ! Inputs diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index cea010aa2..96afc0c38 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -26,7 +26,7 @@ end subroutine rrtmgp_lw_rte_init !! \htmlinclude rrtmgp_lw_rte_run.html !! subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & - nLev, top_at_1, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, & + nLev, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, & sfc_emiss_byband, sources, lw_optical_props_clrsky, lw_optical_props_clouds, & lw_optical_props_precip, lw_optical_props_cnvclouds, & lw_optical_props_MYNNcloudsByBand, lw_optical_props_aerosol, nGauss_angles, & @@ -39,14 +39,12 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, doLWrad, & ! Logical flag for longwave radiation call doLWclrsky, & ! Compute clear-sky fluxes for clear-sky heating-rate? use_LW_jacobian, & ! Compute Jacobian of LW to update radiative fluxes between radiation calls? - do_mynnedmf, & ! Flag for MYNN-EDMF PBL cloud scheme + doGP_sgs_mynn, & ! Flag for sgs MYNN-EDMF PBL cloud scheme + doGP_sgs_cnv, & ! Flagg for sgs convective cloud scheme doGP_lwscat ! Include scattering in LW cloud-optics? integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! nGauss_angles ! Number of angles used in Gaussian quadrature real(kind_phys), dimension(lw_gas_props%get_nband(),ncol), intent(in) :: & sfc_emiss_byband ! Surface emissivity in each band @@ -133,12 +131,12 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, ! ! Include convective cloud? - if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then + if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_cnvclouds%increment(lw_optical_props_clrsky)) endif ! Include MYNN-EDMF PBL clouds? - if (do_mynnedmf) then + if (doGP_sgs_mynn) then call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_MYNNcloudsByBand%increment(lw_optical_props_clrsky)) endif diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 13e5e0204..39dba368b 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -36,30 +36,16 @@ dimensions = () type = logical intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP 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 + type = logical intent = in -[do_mynnedmf] - standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to activate MYNN-EDMF +[doGP_sgs_mynn] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP units = flag dimensions = () type = logical diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index 8a71b4428..ddc3eacb1 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -25,7 +25,7 @@ end subroutine rrtmgp_sw_rte_init !! \htmlinclude rrtmgp_sw_rte.html !! subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay,& - t_lay, top_at_1, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, iSFC, & + t_lay, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, iSFC, & sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, & sw_optical_props_clrsky, sw_optical_props_clouds, sw_optical_props_precip, & sw_optical_props_cnvclouds, sw_optical_props_MYNNcloudsByBand, & @@ -35,16 +35,14 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz ! Inputs logical, intent(in) :: & top_at_1, & ! Vertical ordering flag - do_mynnedmf, & ! Flag for MYNN-EDMG PBL cloud scheme + doGP_sgs_mynn, & ! Flag for MYNN-EDMF PBL cloud scheme + doGP_sgs_cnv, & ! Flag for sgs convective clouds scheme doSWrad, & ! Flag to calculate SW irradiances doSWclrsky ! Compute clear-sky fluxes? integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nday, & ! Number of daytime points nLev, & ! Number of vertical levels - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! iSFC ! Vertical index for surface-level integer, intent(in), dimension(ncol) :: & idxday ! Index array for daytime points @@ -157,12 +155,12 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz ! ! Include convective cloud? - if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then + if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_cnvclouds%increment(sw_optical_props_clrsky)) endif ! Include MYNN-EDMF PBL cloud? - if (do_mynnedmf) then + if (doGP_sgs_mynn) then call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_MYNNcloudsByBand%increment(sw_optical_props_clrsky)) endif diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index b4b5e8bf4..99a0b70e2 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -22,27 +22,6 @@ dimensions = () type = logical intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_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 [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -94,9 +73,16 @@ dimensions = () type = logical intent = in -[do_mynnedmf] - standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to activate MYNN-EDMF +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_mynn] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP units = flag dimensions = () type = logical From ac173e298e2921f74fb3b702c31a0d12f5861009 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 9 Mar 2022 18:11:52 +0000 Subject: [PATCH 099/217] Replaced cld_mynn_ naming convention with cld_pbl_ --- physics/GFS_rrtmgp_cloud_mp.F90 | 56 ++++++++++++++--------------- physics/GFS_rrtmgp_cloud_mp.meta | 10 +++--- physics/rrtmgp_lw_cloud_optics.F90 | 20 +++++------ physics/rrtmgp_lw_cloud_optics.meta | 8 ++--- physics/rrtmgp_sw_cloud_optics.F90 | 20 +++++------ physics/rrtmgp_sw_cloud_optics.meta | 8 ++--- 6 files changed, 61 insertions(+), 61 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 8d01b05e4..561e605a4 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -42,11 +42,11 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic lgfdlmprad, do_mynnedmf, uni_cld, lmfdeep2, p_lev, p_lay, t_lay, qs_lay, q_lay, & relhum, lsmask, xlon, xlat, dx, tv_lay, effrin_cldliq, effrin_cldice, & effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cld_cnv_frac, qci_conv, & - deltaZ, deltaZc, deltaP, qc_mynn, qi_mynn, cld_mynn_frac, con_g, con_rd, con_eps, & + deltaZ, deltaZc, deltaP, qc_mynn, qi_mynn, cld_pbl_frac, con_g, con_rd, con_eps, & con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, cld_frac, cld_lwp, cld_reliq, & cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & - cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_mynn_lwp, & - cld_mynn_reliq, cld_mynn_iwp, cld_mynn_reice, lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, & + cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, lwp_ex, iwp_ex, lwp_fc, iwp_fc, & errmsg, errflg) implicit none @@ -109,7 +109,7 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic deltaP, & ! Layer-thickness (Pa) qc_mynn, & ! qi_mynn, & ! - cld_mynn_frac ! + cld_pbl_frac ! real(kind_phys), dimension(:,:), intent(inout) :: & effrin_cldliq, & ! Effective radius for stratiform liquid cloud-particles (microns) effrin_cldice, & ! Effective radius for stratiform ice cloud-particles (microns) @@ -143,10 +143,10 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles cld_cnv_iwp, & ! Water path for convective ice cloud-particles cld_cnv_reice, & ! Effective radius for convective ice cloud-particles - cld_mynn_lwp, & ! Water path for MYNN SGS PBL liquid cloud-particles - cld_mynn_reliq, & ! Effective radius for MYNN SGS PBL liquid cloud-particles - cld_mynn_iwp, & ! Water path for MYNN SGS PBL ice cloud-particles - cld_mynn_reice ! Effective radius for MYNN SGS PBL ice cloud-particles + cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles + cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles character(len=*), intent(out) :: & errmsg ! Error message integer, intent(out) :: & @@ -224,7 +224,7 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic if(do_mynnedmf) then call cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & qc_mynn, qi_mynn, con_ttp, con_g, & - cld_mynn_lwp, cld_mynn_reliq, cld_mynn_iwp, cld_mynn_reice, cld_mynn_frac) + cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, cld_pbl_frac) endif ! Grell-Freitas convective clouds? @@ -274,10 +274,10 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic where(cld_cnv_reice .gt. radice_upr) cld_cnv_reice = radice_upr endif if (do_mynnedmf) then - where(cld_mynn_reliq .lt. radliq_lwr) cld_mynn_reliq = radliq_lwr - where(cld_mynn_reliq .gt. radliq_upr) cld_mynn_reliq = radliq_upr - where(cld_mynn_reice .lt. radice_lwr) cld_mynn_reice = radice_lwr - where(cld_mynn_reice .gt. radice_upr) cld_mynn_reice = radice_upr + where(cld_pbl_reliq .lt. radliq_lwr) cld_pbl_reliq = radliq_lwr + where(cld_pbl_reliq .gt. radliq_upr) cld_pbl_reliq = radliq_upr + where(cld_pbl_reice .lt. radice_lwr) cld_pbl_reice = radice_lwr + where(cld_pbl_reice .gt. radice_upr) cld_pbl_reice = radice_upr endif endif @@ -382,8 +382,8 @@ end subroutine cloud_mp_GF ! ! ###################################################################################### subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & - qc_mynn, qi_mynn, con_ttp, con_g, cld_mynn_lwp, cld_mynn_reliq, cld_mynn_iwp, & - cld_mynn_reice, cld_mynn_frac) + qc_mynn, qi_mynn, con_ttp, con_g, cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, & + cld_pbl_reice, cld_pbl_frac) implicit none ! Inputs @@ -403,13 +403,13 @@ subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum relhum, & ! qc_mynn, & ! Liquid cloud mixing-ratio (MYNN PBL cloud) qi_mynn, & ! Ice cloud mixing-ratio (MYNN PBL cloud) - cld_mynn_frac ! Cloud-fraction (MYNN PBL cloud) + cld_pbl_frac ! Cloud-fraction (MYNN PBL cloud) ! Outputs real(kind_phys), dimension(:,:),intent(inout) :: & - cld_mynn_lwp, & ! Convective cloud liquid water path - cld_mynn_reliq, & ! Convective cloud liquid effective radius - cld_mynn_iwp, & ! Convective cloud ice water path - cld_mynn_reice ! Convective cloud ice effecive radius + cld_pbl_lwp, & ! Convective cloud liquid water path + cld_pbl_reliq, & ! Convective cloud liquid effective radius + cld_pbl_iwp, & ! Convective cloud ice water path + cld_pbl_reice ! Convective cloud ice effecive radius ! Local integer :: iCol, iLay @@ -417,26 +417,26 @@ subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum do iLay = 1, nLev do iCol = 1, nCol - if (cld_mynn_frac(iCol,iLay) > cld_limit_lower) then + if (cld_pbl_frac(iCol,iLay) > cld_limit_lower) then ! Cloud mixing-ratios (DJS asks: Why is this done?) - qc = qc_mynn(iCol,iLay)*cld_mynn_frac(iCol,iLay) - qi = qi_mynn(iCol,iLay)*cld_mynn_frac(iCol,iLay) + qc = qc_mynn(iCol,iLay)*cld_pbl_frac(iCol,iLay) + qi = qi_mynn(iCol,iLay)*cld_pbl_frac(iCol,iLay) ! LWP/IWP deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. tem1 = (1.0e5/con_g) * deltaP - cld_mynn_lwp(iCol,iLay) = max(0., qc * tem1) - cld_mynn_iwp(iCol,iLay) = max(0., qi * tem1) + cld_pbl_lwp(iCol,iLay) = max(0., qc * tem1) + cld_pbl_iwp(iCol,iLay) = max(0., qi * tem1) ! Particle sizes if (nint(lsmask(iCol)) == 1) then - if(qc > 1.E-8) cld_mynn_reliq(iCol,iLay) = 5.4 + if(qc > 1.E-8) cld_pbl_reliq(iCol,iLay) = 5.4 else ! Cloud water (microns), from Miles et al. - if(qc > 1.E-8) cld_mynn_reliq(iCol,iLay) = 9.6 + if(qc > 1.E-8) cld_pbl_reliq(iCol,iLay) = 9.6 endif ! Cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) - if(qi > 1.E-8) cld_mynn_reice(iCol,iLay) = max(173.45 + 2.14*(t_lay(iCol,iLay)-273.15), 20.) + if(qi > 1.E-8) cld_pbl_reice(iCol,iLay) = max(173.45 + 2.14*(t_lay(iCol,iLay)-273.15), 20.) endif enddo enddo diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index 39706f0e1..f9b1d76b8 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -567,7 +567,7 @@ type = real kind = kind_phys intent = inout -[cld_mynn_frac] +[cld_pbl_frac] standard_name = subgrid_scale_cloud_area_fraction_in_atmosphere_layer long_name = subgrid cloud fraction from PBL scheme units = frac @@ -575,7 +575,7 @@ type = real kind = kind_phys intent = in -[cld_mynn_lwp] +[cld_pbl_lwp] standard_name = MYNN_SGS_cloud_liquid_water_path long_name = layer convective cloud liquid water path units = g m-2 @@ -583,7 +583,7 @@ type = real kind = kind_phys intent = inout -[cld_mynn_iwp] +[cld_pbl_iwp] standard_name = MYNN_SGS_cloud_ice_water_path long_name = layer convective cloud ice water path units = g m-2 @@ -591,7 +591,7 @@ type = real kind = kind_phys intent = inout -[cld_mynn_reliq] +[cld_pbl_reliq] standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud long_name = mean effective radius for liquid MYNN_SGS cloud units = um @@ -599,7 +599,7 @@ type = real kind = kind_phys intent = inout -[cld_mynn_reice] +[cld_pbl_reice] standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud long_name = mean effective radius for ice MYNN_SGS cloud units = um diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index c83929b31..ba8b92a03 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -386,8 +386,8 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, do_mynnedmf, imfdeepcnv, & imfdeepcnv_gf, imfdeepcnv_samf, nCol, nLev, nbndsGPlw , p_lay, cld_frac, cld_lwp, & cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & - precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_mynn_lwp,& - cld_mynn_reliq, cld_mynn_iwp, cld_mynn_reice, lon, lat, cldtaulw, & + precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, & + cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, lon, lat, cldtaulw, & lw_optical_props_cloudsByBand, lw_optical_props_cnvcloudsByBand, & lw_optical_props_MYNNcloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) @@ -427,10 +427,10 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) - cld_mynn_lwp, & - cld_mynn_reliq, & - cld_mynn_iwp, & - cld_mynn_reice + cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles + cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles ! Outputs character(len=*), intent(out) :: & @@ -501,10 +501,10 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw lw_optical_props_MYNNcloudsByBand%gpt2band(iBand) = iBand end do call check_error_msg('rrtmgp_lw_MYNNcloud_optics_run - MYNN-EDMF cloud',lw_cloud_props%cloud_optics(& - cld_mynn_lwp, & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) - cld_mynn_iwp, & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) - cld_mynn_reliq, & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) - cld_mynn_reice, & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) + cld_pbl_lwp, & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) + cld_pbl_iwp, & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) + cld_pbl_reliq, & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) + cld_pbl_reice, & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) lw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties ! in each band endif diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index d1486f439..c58496dc5 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -295,7 +295,7 @@ type = real kind = kind_phys intent = in -[cld_mynn_lwp] +[cld_pbl_lwp] standard_name = MYNN_SGS_cloud_liquid_water_path long_name = layer convective cloud liquid water path units = g m-2 @@ -303,7 +303,7 @@ type = real kind = kind_phys intent = in -[cld_mynn_iwp] +[cld_pbl_iwp] standard_name = MYNN_SGS_cloud_ice_water_path long_name = layer convective cloud ice water path units = g m-2 @@ -311,7 +311,7 @@ type = real kind = kind_phys intent = in -[cld_mynn_reliq] +[cld_pbl_reliq] standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud long_name = mean effective radius for liquid MYNN_SGS cloud units = um @@ -319,7 +319,7 @@ type = real kind = kind_phys intent = in -[cld_mynn_reice] +[cld_pbl_reice] standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud long_name = mean effective radius for ice MYNN_SGS cloud units = um diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index d02fde7d7..f889c318b 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -398,8 +398,8 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw doGP_cldoptics_PADE, doGP_cldoptics_LUT, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & imfdeepcnv_samf, nCol, nLev, nDay, nbndsGPsw, idxday, cld_frac, cld_lwp, cld_reliq, & cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & - cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_mynn_lwp, cld_mynn_reliq,& - cld_mynn_iwp, cld_mynn_reice, sw_optical_props_cloudsByBand, & + cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, & + cld_pbl_iwp, cld_pbl_reice, sw_optical_props_cloudsByBand, & sw_optical_props_cnvcloudsByBand, sw_optical_props_precipByBand, & sw_optical_props_MYNNcloudsByBand, cldtausw, errmsg, errflg) @@ -437,10 +437,10 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) - cld_mynn_lwp, & - cld_mynn_reliq, & - cld_mynn_iwp, & - cld_mynn_reice + cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles + cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles ! Outputs character(len=*), intent(out) :: & errmsg ! CCPP error message @@ -505,10 +505,10 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw sw_optical_props_MYNNcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_sw_MYNNcloud_optics_run - MYNN-EDMF cloud',sw_cloud_props%cloud_optics(& - cld_mynn_lwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) - cld_mynn_iwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) - cld_mynn_reliq(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) - cld_mynn_reice(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) + cld_pbl_lwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) + cld_pbl_iwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) + cld_pbl_reliq(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) + cld_pbl_reice(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) sw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties ! in each band endif diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta index b2f7f48f6..064b7cf80 100644 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ b/physics/rrtmgp_sw_cloud_optics.meta @@ -287,7 +287,7 @@ type = real kind = kind_phys intent = in -[cld_mynn_lwp] +[cld_pbl_lwp] standard_name = MYNN_SGS_cloud_liquid_water_path long_name = layer convective cloud liquid water path units = g m-2 @@ -295,7 +295,7 @@ type = real kind = kind_phys intent = in -[cld_mynn_iwp] +[cld_pbl_iwp] standard_name = MYNN_SGS_cloud_ice_water_path long_name = layer convective cloud ice water path units = g m-2 @@ -303,7 +303,7 @@ type = real kind = kind_phys intent = in -[cld_mynn_reliq] +[cld_pbl_reliq] standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud long_name = mean effective radius for liquid MYNN_SGS cloud units = um @@ -311,7 +311,7 @@ type = real kind = kind_phys intent = in -[cld_mynn_reice] +[cld_pbl_reice] standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud long_name = mean effective radius for ice MYNN_SGS cloud units = um From 11b50ca1f939042faf1ec3d10707fb73c2af5f4b Mon Sep 17 00:00:00 2001 From: helin wei Date: Wed, 9 Mar 2022 18:21:04 +0000 Subject: [PATCH 100/217] to read new hig-res ice climatology data --- physics/sfcsub.F | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index e8b61f083..cdc91cca9 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -34,7 +34,8 @@ module sfccyc_module integer, parameter :: kpdalf(2)=(/214,217/) ! real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 - integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata +! integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata + integer, parameter :: xdata=7200, ydata=3600, mdata=xdata*ydata integer :: veg_type_landice integer :: soil_type_landice integer :: num_threads From 475b1be7dfad087ac456c79783b2c0c380a8ce5d Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 9 Mar 2022 21:26:22 +0000 Subject: [PATCH 101/217] Fixed inconsistency between G/GP in Thompson MP. --- physics/GFS_rrtmgp_cloud_mp.F90 | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 561e605a4..2ad5d2df2 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -713,7 +713,11 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c tracer(1:nCol,1:nLev,i_cldgrpl) ! Cloud water path (g/m2) - do iLay = 1, nLev + cld_lwp(:,:) = 0.0 + cld_iwp(:,:) = 0.0 + cld_rwp(:,:) = 0.0 + cld_swp(:,:) = 0.0 + do iLay = 1, nLev-1 do iCol = 1, nCol ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. @@ -726,7 +730,8 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c enddo ! Xu-Randall (1996) cloud-fraction. **Additionally, Conditioned on relative-humidity** - do iLay = 1, nLev + cld_frac(:,:) = 0.0 + do iLay = 1, nLev-1 do iCol = 1, nCol if (relhum(iCol,iLay) > 0.99) then cld_frac(iCol,iLay) = 1._kind_phys From 182b2c68e95213d444264ba2610efb1c421f936b Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 9 Mar 2022 21:33:26 +0000 Subject: [PATCH 102/217] Housekeeping, combine loops. --- physics/GFS_rrtmgp_cloud_mp.F90 | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 2ad5d2df2..0dd34d34a 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -712,11 +712,11 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel tracer(1:nCol,1:nLev,i_cldgrpl) - ! Cloud water path (g/m2) cld_lwp(:,:) = 0.0 cld_iwp(:,:) = 0.0 cld_rwp(:,:) = 0.0 cld_swp(:,:) = 0.0 + cld_frac(:,:) = 0.0 do iLay = 1, nLev-1 do iCol = 1, nCol ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) @@ -726,13 +726,8 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) - enddo - enddo - ! Xu-Randall (1996) cloud-fraction. **Additionally, Conditioned on relative-humidity** - cld_frac(:,:) = 0.0 - do iLay = 1, nLev-1 - do iCol = 1, nCol + ! Xu-Randall (1996) cloud-fraction. **Additionally, Conditioned on relative-humidity** if (relhum(iCol,iLay) > 0.99) then cld_frac(iCol,iLay) = 1._kind_phys else From 646c65bd1292e6b0a2dbe4875385cc00185310a5 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 9 Mar 2022 22:05:50 +0000 Subject: [PATCH 103/217] Some more cleanup of cloud-fraction... --- physics/GFS_rrtmgp_cloud_mp.F90 | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 0dd34d34a..ac4c90caa 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -253,10 +253,14 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic ! Thomson MP using modified Xu-Randall cloud-fraction (additionally conditioned on RH) alpha0 = 2000. + if (lmfshal) then + alpha0 = 100. + if (lmfdeep2) alpha0 = 200. + endif call cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, & relhum, con_g, con_rd, con_eps, alpha0, lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - cld_frac, cld_lwp, cld_iwp, cld_swp, cld_rwp) + cld_frac, cld_lwp, cld_iwp, cld_swp, cld_rwp, cond_cfrac_onRH = .true.) endif ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from @@ -656,10 +660,12 @@ end subroutine cloud_mp_uni subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, relhum, & con_g, con_rd, con_eps, alpha0, lwp_ex, iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp,& - cld_iwp, cld_swp, cld_rwp) + cld_iwp, cld_swp, cld_rwp, cond_cfrac_onRH) implicit none ! Inputs + logical, intent(in), optional :: & + cond_cfrac_onRH integer, intent(in) :: & nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers @@ -728,7 +734,7 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) ! Xu-Randall (1996) cloud-fraction. **Additionally, Conditioned on relative-humidity** - if (relhum(iCol,iLay) > 0.99) then + if (present(cond_cfrac_onRH) .and. relhum(iCol,iLay) > 0.99) then cld_frac(iCol,iLay) = 1._kind_phys else cld_mr = cld_condensate(iCol,iLay,1) + cld_condensate(iCol,iLay,2) + & From 4ed3982e48694e9abe52ae2dbf48d79068484c43 Mon Sep 17 00:00:00 2001 From: helin wei Date: Thu, 10 Mar 2022 17:49:49 +0000 Subject: [PATCH 104/217] replace fveg by lai/laimax to be used for dependent --- physics/module_sf_noahmplsm.f90 | 60 ++++++++++++++++++++++++--------- 1 file changed, 45 insertions(+), 15 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 919d81507..7e17f511d 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -682,6 +682,10 @@ subroutine noahmp_sflx (parameters, & logical :: crop_active !< flag to run crop model ! add canopy heat storage (C.He added based on GY Niu's communication) real :: canhs ! canopy heat storage change w/m2 +! maximum lai/sai used for some parameterizations based on plant growthi + real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided + ! intent (out) variables need to be assigned a value. these normally get assigned values ! only if dveg == 2. @@ -732,7 +736,7 @@ subroutine noahmp_sflx (parameters, & ! vegetation phenology call phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai ,igs, pgs) + lai , sai , laimax, saimax, troot , elai , esai ,igs, pgs) !input gvf should be consistent with lai if(dveg == 1 .or. dveg == 6 .or. dveg == 7) then @@ -776,7 +780,7 @@ subroutine noahmp_sflx (parameters, & sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,laimax, saimax, fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in @@ -1055,7 +1059,7 @@ end subroutine atm !!vegetation phenology considering vegetation canopy being buried by snow and !!evolution in time. subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai , igs, pgs) + lai , sai , laimax, saimax, troot , elai , esai , igs, pgs) ! -------------------------------------------------------------------------------------------------- ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time @@ -1076,6 +1080,8 @@ subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yea real (kind=kind_phys) , intent(inout) :: sai !sai, unadjusted for burying by snow ! outputs + real (kind=kind_phys) , intent(out ) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys) , intent(out ) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys) , intent(out ) :: elai !leaf area index, after burying by snow real (kind=kind_phys) , intent(out ) :: esai !stem area index, after burying by snow real (kind=kind_phys) , intent(out ) :: igs !growing season index (0=off, 1=on) @@ -1095,6 +1101,23 @@ subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yea real (kind=kind_phys) :: t !current month (1.00, ..., 12.00) ! -------------------------------------------------------------------------------------------------- +! derive monthly maximum lai and sai from monthly lai + + laimax=parameters%laim(1) + saimax=parameters%saim(1) + + do k=1,12 + + if(parameters%laim(k).ge.laimax)then + laimax=parameters%laim(k) + endif + + if(parameters%saim(k).ge.saimax)then + saimax=parameters%saim(k) + endif + + enddo + if (croptype == 0) then if ( dveg == 1 .or. dveg == 3 .or. dveg == 4 ) then @@ -1614,7 +1637,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,laimax, saimax, fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in @@ -1709,6 +1732,8 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: cosz !cosine solar zenith angle (0-1) real (kind=kind_phys) , intent(in) :: elai !lai adjusted for burying by snow real (kind=kind_phys) , intent(in) :: esai !lai adjusted for burying by snow + real (kind=kind_phys) , intent(in) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys) , intent(in) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys) , intent(in) :: fwet !fraction of canopy that is wet [-] real (kind=kind_phys) , intent(in) :: fveg !greeness vegetation fraction (-) real (kind=kind_phys) , intent(in) :: shdfac !< green vegetation fraction [0.0-1.0] @@ -2039,7 +2064,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , fveg, & !in + lat ,z0m ,zlvl ,vegtyp , elai,laimax, & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2163,7 +2188,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in - fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + laimax, saimax,fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -2429,7 +2454,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , fveg,& !in + lat ,z0m ,zlvl ,vegtyp , elai, laimax,& !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2454,8 +2479,9 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: lat !latitude (radians) real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) - integer , intent(in) :: vegtyp !vegtyp type - real (kind=kind_phys), intent(in) :: fveg !green vegetation fraction [0.0-1.0] + real (kind=kind_phys), intent(in) :: elai !lai adjusted for burying by snow + real (kind=kind_phys), intent(in) :: laimax !< monthly maximum leaf area index, one-sided + integer , intent(in) :: vegtyp !vegtyp type ! outputs real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] @@ -2504,7 +2530,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) - df(1) = df(1) * exp (sbeta * fveg) + df(1) = df(1) * exp (sbeta * elai/laimax) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -3650,7 +3676,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in - fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + laimax, saimax,fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -3706,6 +3732,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in) :: fsno !snow fraction real (kind=kind_phys), intent(in) :: snowh !actual snow depth [m] + real (kind=kind_phys), intent(in) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys), intent(in) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys), intent(in) :: fwet !wetted fraction of canopy real (kind=kind_phys), intent(in) :: cwp !canopy wind parameter @@ -4032,7 +4060,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp , & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,laimax,saimax,vegtyp, & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out @@ -4492,7 +4520,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 ,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,4.5,1.4,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out @@ -5095,7 +5123,7 @@ end subroutine sfcdif2 !! compute surface drag coefficient cm for momentum and ch for heat. subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,vegetated,vaie ,vegtyp , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie,laimax,saimax,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf ,cm ,ch ) !out @@ -5126,6 +5154,8 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys), intent(in ) :: garea1 ! grid area [km2] logical, intent(in ) :: vegetated ! .true. if vegetated real (kind=kind_phys), intent(in ) :: vaie ! vegetation area index [m2/m2] + real (kind=kind_phys), intent(in ) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys), intent(in ) :: laimax !< monthly maximum leaf area index, one-sided integer , intent(in ) :: vegtyp ! vegetation category real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity [m/s] real (kind=kind_phys), intent(inout) :: fm ! momentum stability correction, weighted by prior iters @@ -5207,7 +5237,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(fveg, 0.1_kind_phys) + tem2 = max(vaie/(laimax+saimax), 0.1_kind_phys) zvfun1 = sqrt(tem1 * tem2) gdx = sqrt(garea1) From 8e1b316051e6039101e8c3173a5af9dd2df63590 Mon Sep 17 00:00:00 2001 From: helin wei Date: Thu, 10 Mar 2022 19:11:01 +0000 Subject: [PATCH 105/217] simplify the code with internal function maxval --- physics/module_sf_noahmplsm.f90 | 56 ++++++++++----------------------- 1 file changed, 17 insertions(+), 39 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 7e17f511d..c945e66ff 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -683,8 +683,6 @@ subroutine noahmp_sflx (parameters, & ! add canopy heat storage (C.He added based on GY Niu's communication) real :: canhs ! canopy heat storage change w/m2 ! maximum lai/sai used for some parameterizations based on plant growthi - real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! intent (out) variables need to be assigned a value. these normally get assigned values @@ -736,7 +734,7 @@ subroutine noahmp_sflx (parameters, & ! vegetation phenology call phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , laimax, saimax, troot , elai , esai ,igs, pgs) + lai , sai , troot , elai , esai ,igs, pgs) !input gvf should be consistent with lai if(dveg == 1 .or. dveg == 6 .or. dveg == 7) then @@ -780,7 +778,7 @@ subroutine noahmp_sflx (parameters, & sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,laimax, saimax, fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in @@ -1059,7 +1057,7 @@ end subroutine atm !!vegetation phenology considering vegetation canopy being buried by snow and !!evolution in time. subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , laimax, saimax, troot , elai , esai , igs, pgs) + lai , sai , troot , elai , esai , igs, pgs) ! -------------------------------------------------------------------------------------------------- ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time @@ -1080,8 +1078,6 @@ subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yea real (kind=kind_phys) , intent(inout) :: sai !sai, unadjusted for burying by snow ! outputs - real (kind=kind_phys) , intent(out ) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys) , intent(out ) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys) , intent(out ) :: elai !leaf area index, after burying by snow real (kind=kind_phys) , intent(out ) :: esai !stem area index, after burying by snow real (kind=kind_phys) , intent(out ) :: igs !growing season index (0=off, 1=on) @@ -1101,23 +1097,6 @@ subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yea real (kind=kind_phys) :: t !current month (1.00, ..., 12.00) ! -------------------------------------------------------------------------------------------------- -! derive monthly maximum lai and sai from monthly lai - - laimax=parameters%laim(1) - saimax=parameters%saim(1) - - do k=1,12 - - if(parameters%laim(k).ge.laimax)then - laimax=parameters%laim(k) - endif - - if(parameters%saim(k).ge.saimax)then - saimax=parameters%saim(k) - endif - - enddo - if (croptype == 0) then if ( dveg == 1 .or. dveg == 3 .or. dveg == 4 ) then @@ -1637,7 +1616,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,laimax, saimax, fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in @@ -1732,8 +1711,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: cosz !cosine solar zenith angle (0-1) real (kind=kind_phys) , intent(in) :: elai !lai adjusted for burying by snow real (kind=kind_phys) , intent(in) :: esai !lai adjusted for burying by snow - real (kind=kind_phys) , intent(in) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys) , intent(in) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys) , intent(in) :: fwet !fraction of canopy that is wet [-] real (kind=kind_phys) , intent(in) :: fveg !greeness vegetation fraction (-) real (kind=kind_phys) , intent(in) :: shdfac !< green vegetation fraction [0.0-1.0] @@ -2064,7 +2041,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , elai,laimax, & !in + lat ,z0m ,zlvl ,vegtyp , elai, & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2188,7 +2165,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in - laimax, saimax,fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -2454,7 +2431,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , elai, laimax,& !in + lat ,z0m ,zlvl ,vegtyp , elai, & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2480,7 +2457,6 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) real (kind=kind_phys), intent(in) :: elai !lai adjusted for burying by snow - real (kind=kind_phys), intent(in) :: laimax !< monthly maximum leaf area index, one-sided integer , intent(in) :: vegtyp !vegtyp type ! outputs @@ -2498,6 +2474,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) real (kind=kind_phys), dimension( 1:nsoil) :: sice !soil ice content real (kind=kind_phys), parameter :: sbeta = -2.0 + real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! -------------------------------------------------------------------------------------------------- ! compute snow thermal conductivity and heat capacity @@ -2530,6 +2507,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) + laimax = maxval(parameters%laim) df(1) = df(1) * exp (sbeta * elai/laimax) ! compute lake thermal properties @@ -3676,7 +3654,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in - laimax, saimax,fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -3732,8 +3710,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in) :: fsno !snow fraction real (kind=kind_phys), intent(in) :: snowh !actual snow depth [m] - real (kind=kind_phys), intent(in) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys), intent(in) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys), intent(in) :: fwet !wetted fraction of canopy real (kind=kind_phys), intent(in) :: cwp !canopy wind parameter @@ -4060,7 +4036,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,laimax,saimax,vegtyp, & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp, & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out @@ -4520,7 +4496,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,4.5,1.4,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out @@ -5123,7 +5099,7 @@ end subroutine sfcdif2 !! compute surface drag coefficient cm for momentum and ch for heat. subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,vegetated,vaie,laimax,saimax,vegtyp , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf ,cm ,ch ) !out @@ -5154,8 +5130,6 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys), intent(in ) :: garea1 ! grid area [km2] logical, intent(in ) :: vegetated ! .true. if vegetated real (kind=kind_phys), intent(in ) :: vaie ! vegetation area index [m2/m2] - real (kind=kind_phys), intent(in ) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys), intent(in ) :: laimax !< monthly maximum leaf area index, one-sided integer , intent(in ) :: vegtyp ! vegetation category real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity [m/s] real (kind=kind_phys), intent(inout) :: fm ! momentum stability correction, weighted by prior iters @@ -5183,10 +5157,14 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys) :: sigmaa ! momentum partition parameter real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 + real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! ------------------------------------------------------------------------------------------------- fv = ustarx + laimax = maxval(parameters%laim) + saimax = maxval(parameters%saim) ! fv = ur*vkc/log((zlvl-zpd)/z0m) if(vegetated) then From 3206fa9c6bdf18c0832af158be2ec8ff8b2b8ae8 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 10 Mar 2022 20:22:41 +0000 Subject: [PATCH 106/217] Changes from code review. --- physics/GFS_rrtmgp_cloud_mp.F90 | 61 ++++++++++++---------------- physics/GFS_rrtmgp_cloud_mp.meta | 2 +- physics/GFS_rrtmgp_cloud_overlap.F90 | 10 ----- physics/GFS_rrtmgp_pre.F90 | 46 ++++++++++----------- physics/GFS_rrtmgp_pre.meta | 6 +-- physics/rrtmgp_lw_cloud_optics.F90 | 6 +-- physics/rrtmgp_lw_cloud_sampling.F90 | 7 ++-- physics/rrtmgp_lw_rte.F90 | 4 +- physics/rrtmgp_sw_cloud_optics.F90 | 6 +-- physics/rrtmgp_sw_cloud_sampling.F90 | 8 ++-- physics/rrtmgp_sw_rte.F90 | 15 ++++--- 11 files changed, 74 insertions(+), 97 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index ac4c90caa..acd63f483 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -25,10 +25,6 @@ module GFS_rrtmgp_cloud_mp public GFS_rrtmgp_cloud_mp_init, GFS_rrtmgp_cloud_mp_run, GFS_rrtmgp_cloud_mp_finalize contains - ! ###################################################################################### - ! ###################################################################################### - subroutine GFS_rrtmgp_cloud_mp_init() - end subroutine GFS_rrtmgp_cloud_mp_init !! \section arg_table_GFS_rrtmgp_cloud_mp_run !! \htmlinclude GFS_rrtmgp_cloud_mp_run_html @@ -289,11 +285,6 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic end subroutine GFS_rrtmgp_cloud_mp_run - ! ###################################################################################### - ! ###################################################################################### - subroutine GFS_rrtmgp_cloud_mp_finalize() - end subroutine GFS_rrtmgp_cloud_mp_finalize - ! ###################################################################################### ! Compute cloud radiative properties for Grell-Freitas convective cloud scheme. ! (Adopted from module_SGSCloud_RadPre) @@ -342,19 +333,19 @@ subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, ! Local integer :: iCol, iLay real(kind_phys) :: tem1, deltaP, clwc, qc, qi + real(kind_phys), parameter :: tem1 = 1.0e5/con_g do iLay = 1, nLev do iCol = 1, nCol if (qci_conv(iCol,iLay) > 0.) then ! Partition the convective clouds by phase. - qc = qci_conv(iCol,iLay)*( min(1., max(0., (t_lay(iCol,iLay)-244.)/25.))) - qi = qci_conv(iCol,iLay)*(1. - min(1., max(0., (t_lay(iCol,iLay)-244.)/25.))) + qc = qci_conv(iCol,iLay)*( min(1., max(0., (t_lay(iCol,iLay)-244.)*0.04))) + qi = qci_conv(iCol,iLay)*(1. - min(1., max(0., (t_lay(iCol,iLay)-244.)*0.04))) ! Compute LWP/IWP - deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. - tem1 = (1.0e5/con_g) * deltaP - cld_cnv_lwp(iCol,iLay) = max(0., qc * tem1) - cld_cnv_iwp(iCol,iLay) = max(0., qi * tem1) + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 + cld_cnv_lwp(iCol,iLay) = max(0., qc * tem1*deltaP) + cld_cnv_iwp(iCol,iLay) = max(0., qi * tem1*deltaP) ! Particle sizes if (nint(lsmask(iCol)) == 1) then !land @@ -418,6 +409,7 @@ subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum ! Local integer :: iCol, iLay real(kind_phys) :: tem1, qc, qi, deltaP + real(kind_phys), parameter :: tem1 = 1.0e5/con_g do iLay = 1, nLev do iCol = 1, nCol @@ -427,10 +419,9 @@ subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum qi = qi_mynn(iCol,iLay)*cld_pbl_frac(iCol,iLay) ! LWP/IWP - deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. - tem1 = (1.0e5/con_g) * deltaP - cld_pbl_lwp(iCol,iLay) = max(0., qc * tem1) - cld_pbl_iwp(iCol,iLay) = max(0., qi * tem1) + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay)) + cld_pbl_lwp(iCol,iLay) = max(0., qc * tem1 * deltaP) + cld_pbl_iwp(iCol,iLay) = max(0., qi * tem1 * deltaP) ! Particle sizes if (nint(lsmask(iCol)) == 1) then @@ -493,7 +484,7 @@ subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, do iCol = 1, nCol if (cnv_mixratio(iCol,iLay) > 0._kind_phys) then tem1 = min(1.0, max(0.0, (con_ttp-t_lay(iCol,iLay))*0.05)) - deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 clwc = max(0.0, cnv_mixratio(iCol,iLay)) * con_g * deltaP cld_cnv_iwp(iCol,iLay) = clwc * tem1 cld_cnv_lwp(iCol,iLay) = clwc - cld_cnv_iwp(iCol,iLay) @@ -574,8 +565,9 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai cld_rerain ! Cloud rain effective radius ! Local variables - real(kind_phys) :: tem1,tem2,tem3,pfac,deltaP + real(kind_phys) :: tem2,tem3,pfac,deltaP real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate + real(kind_phys), parameter :: tem1 = 1.0e5/con_g integer :: iCol,iLay,l,ncndl ! Cloud condensate @@ -592,13 +584,12 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai do iCol = 1, nCol ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) if (cld_frac(iCol,iLay) > cld_limit_lower) then - deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. - tem1 = (1.0e5/con_g) * deltaP - cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) - cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 + cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1 * deltaP) + cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1 * deltaP) if (ncnd > 2) then - cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) - cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) + cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1 * deltaP) + cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1 * deltaP) endif endif enddo @@ -626,7 +617,7 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai ! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. tem2 = t_lay(iCol,iLay) - con_ttp if (cld_iwp(iCol,iLay) > 0.0) then - deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 tem3 = (con_g/con_rd ) * cld_iwp(iCol,iLay) * (0.01*p_lay(iCol,iLay)) / (deltaP*tv_lay(iCol,iLay)) if (tem2 < -50.0) then cld_reice(iCol,iLay) = (1250.0/9.917) * tem3 ** 0.109 @@ -707,8 +698,9 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c cld_rwp ! Cloud rain water path ! Local variables - real(kind_phys) :: pfac, tem1, cld_mr, deltaP + real(kind_phys) :: pfac, cld_mr, deltaP real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate + real(kind_phys), parameter :: tem1 = 1.0e5/con_g integer :: iCol,iLay,l ! Cloud condensate @@ -726,12 +718,11 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c do iLay = 1, nLev-1 do iCol = 1, nCol ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) - deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))/100. - tem1 = (1.0e5/con_g) * deltaP - cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) - cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) - cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) - cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 + cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1 * deltaP) + cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1 * deltaP) + cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1 * deltaP) + cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1 * deltaP) ! Xu-Randall (1996) cloud-fraction. **Additionally, Conditioned on relative-humidity** if (present(cond_cfrac_onRH) .and. relhum(iCol,iLay) > 0.99) then diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index f9b1d76b8..88530d84c 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -423,7 +423,7 @@ units = J kg-1 K-1 dimensions = () type = real - kind = kind_phys + kind = kind_phys intent = in [con_eps] standard_name = ratio_of_dry_air_to_water_vapor_gas_constants diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 index 7f092dba3..13794641b 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -11,11 +11,6 @@ module GFS_rrtmgp_cloud_overlap contains ! ###################################################################################### ! ###################################################################################### - subroutine GFS_rrtmgp_cloud_overlap_init() - end subroutine GFS_rrtmgp_cloud_overlap_init - - ! ###################################################################################### - ! ###################################################################################### !! \section arg_table_GFS_rrtmgp_cloud_overlap_run !! \htmlinclude GFS_rrtmgp_cloud_overlap_run.html !! @@ -128,9 +123,4 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, precip_overlap_param = cloud_overlap_param end subroutine GFS_rrtmgp_cloud_overlap_run - - ! ######################################################################################### - ! ######################################################################################### - subroutine GFS_rrtmgp_cloud_overlap_finalize() - end subroutine GFS_rrtmgp_cloud_overlap_finalize end module GFS_rrtmgp_cloud_overlap diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index d222ac498..e7cb31ce5 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -99,11 +99,11 @@ end subroutine GFS_rrtmgp_pre_init !! \htmlinclude GFS_rrtmgp_pre_run.html !! subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, fhlwr, & - xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, coslat, sinlat, con_g, con_rd, con_eps, con_epsm1,& - con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, maxGPtemp, raddt, & - p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, tracer, deltaZ, deltaZc, deltaP, & - active_gases_array, gas_concentrations, tsfc_radtime, coszen, coszdg, top_at_1, iSFC,& - iTOA, errmsg, errflg) + xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, coslat, sinlat, con_g, con_rd, & + con_eps, con_epsm1, con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, & + maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, & + relhum, tracer, deltaZ, deltaZc, deltaP, active_gases_array, gas_concentrations, & + tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -129,20 +129,21 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw con_fvirt, & ! Physical constant: Inverse of epsilon minus one con_epsqs, & ! Physical constant: Minimum saturation mixing-ratio (kg/kg) solhr ! Time in hours after 00z at the current timestep - real(kind_phys), dimension(nCol), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & xlon, & ! Longitude xlat, & ! Latitude tsfc, & ! Surface skin temperature (K) coslat, & ! Cosine(latitude) sinlat ! Sine(latitude) - real(kind_phys), dimension(nCol,nLev), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & prsl, & ! Pressure at model-layer centers (Pa) tgrs, & ! Temperature at model-layer centers (K) - prslk ! Exner function at model layer centers (1) - real(kind_phys), dimension(nCol,nLev+1), intent(in) :: & + prslk, & ! Exner function at model layer centers (1) prsi ! Pressure at model-interfaces (Pa) - real(kind_phys), dimension(nCol,nLev,nTracers), intent(in) :: & + real(kind_phys), dimension(:,:,:), intent(in) :: & qgrs ! Tracer concentrations (kg/kg) + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array ! Outputs character(len=*), intent(out) :: & @@ -155,11 +156,13 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw top_at_1 ! Vertical ordering flag real(kind_phys), intent(inout) :: & raddt ! Radiation time-step - real(kind_phys), dimension(ncol), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & tsfg, & ! Ground temperature tsfa, & ! Skin temperature - tsfc_radtime ! Surface temperature at radiation timestep - real(kind_phys), dimension(nCol,nLev), intent(inout) :: & + tsfc_radtime, & ! Surface temperature at radiation timestep + coszen, & ! Cosine of SZA + coszdg ! Cosine of SZA, daytime + real(kind_phys), dimension(:,:), intent(inout) :: & p_lay, & ! Pressure at model-layer t_lay, & ! Temperature at model layer q_lay, & ! Water-vapor mixing ratio (kg/kg) @@ -168,20 +171,14 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw qs_lay, & ! Saturation vapor pressure at model-layers deltaZ, & ! Layer thickness (m) deltaZc, & ! Layer thickness (m) (between layer centers) - deltaP ! Layer thickness (Pa) - real(kind_phys), dimension(nCol,nLev+1), intent(inout) :: & + deltaP, & ! Layer thickness (Pa) p_lev, & ! Pressure at model-interface t_lev ! Temperature at model-interface - real(kind_phys), dimension(nCol, nLev, nTracers),intent(inout) :: & + real(kind_phys), dimension(:,:,:),intent(inout) :: & tracer ! Array containing trace gases - character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array type(ty_gas_concs), intent(inout) :: & gas_concentrations ! RRTMGP DDT: gas volumne mixing ratios - real(kind_phys), dimension(:), intent(inout) :: & - coszen, & ! Cosine of SZA - coszdg ! Cosine of SZA, daytime - + ! Local variables integer :: i, j, iCol, iBand, iLay real(kind_phys),dimension(nCol,nLev) :: vmr_o3, vmr_h2o @@ -190,6 +187,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw real(kind_phys), dimension(nLev) :: hgtc real(kind_phys), dimension(nCol,nLev) :: o3_lay real(kind_phys), dimension(nCol,nLev, NF_VGAS) :: gas_vmr + real(kind_phys), parameter :: con_rdog = con_rd/con_g ! Initialize CCPP error handling variables errmsg = '' @@ -271,7 +269,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw if (top_at_1) then ! Layer thickness (m) do iLay=1,nLev - deltaZ(iCol,iLay) = ((con_rd/con_g)) * abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) * tv_lay(iCol,iLay) + deltaZ(iCol,iLay) = con_rdog * abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) * tv_lay(iCol,iLay) enddo ! Height at layer boundaries hgtb(nLev+1) = 0._kind_phys @@ -292,7 +290,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw else ! Layer thickness (m) do iLay=nLev,1,-1 - deltaZ(iCol,iLay) = ((con_rd/con_g)) * abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) * tv_lay(iCol,iLay) + deltaZ(iCol,iLay) = con_rdog * abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) * tv_lay(iCol,iLay) enddo ! Height at layer boundaries hgtb(1) = 0._kind_phys diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 7fa29ea8c..88face855 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -331,7 +331,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [deltaZc] standard_name = layer_thickness_from_layer_center long_name = layer_thickness @@ -339,7 +339,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [deltaP] standard_name = layer_thickness_in_Pa long_name = layer_thickness_in_Pa @@ -347,7 +347,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [top_at_1] standard_name = flag_for_vertical_ordering_in_RRTMGP long_name = flag for vertical ordering in RRTMGP diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index ba8b92a03..835261071 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -408,10 +408,10 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw imfdeepcnv, & ! imfdeepcnv_gf, & ! imfdeepcnv_samf ! - real(kind_phys), dimension(nCol), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & lon, & ! Longitude lat ! Latitude - real(kind_phys), dimension(ncol,nLev),intent(in) :: & + real(kind_phys), dimension(:,:),intent(in) :: & p_lay, & ! Layer pressure (Pa) cld_frac, & ! Total cloud fraction by layer cld_lwp, & ! Cloud liquid water path @@ -442,7 +442,7 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) lw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (MYNN-PBL cloud) lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) - real(kind_phys), dimension(ncol,nLev), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & cldtaulw ! Approx 10.mu band layer cloud optical depth ! Local variables diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 index fad6c9b61..cf7c0535e 100644 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ b/physics/rrtmgp_lw_cloud_sampling.F90 @@ -44,16 +44,15 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iov iovr_exp, & ! Flag for exponential cloud overlap method iovr_exprand, & ! Flag for exponential-random cloud overlap method isubc_lw - integer,intent(in),dimension(ncol) :: & + integer,intent(in),dimension(:) :: & icseed_lw ! auxiliary special cloud related array when module ! variable isubc_lw=2, it provides permutation seed ! for each column profile that are used for generating ! random numbers. when isubc_lw /=2, it will not be used. - real(kind_phys), dimension(ncol,nLev),intent(in) :: & + real(kind_phys), dimension(:,:),intent(in) :: & cld_frac, & ! Total cloud fraction by layer cld_cnv_frac, & ! Convective cloud fraction by layer - precip_frac ! Precipitation fraction by layer - real(kind_phys), dimension(ncol,nLev), intent(in) :: & + precip_frac, & ! Precipitation fraction by layer cloud_overlap_param, & ! Cloud overlap parameter cnv_cloud_overlap_param, & ! Convective cloud overlap parameter precip_overlap_param ! Precipitation overlap parameter diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index 96afc0c38..131b7d6e5 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -46,7 +46,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels nGauss_angles ! Number of angles used in Gaussian quadrature - real(kind_phys), dimension(lw_gas_props%get_nband(),ncol), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & sfc_emiss_byband ! Surface emissivity in each band type(ty_source_func_lw),intent(in) :: & sources ! RRTMGP DDT: longwave source functions @@ -59,7 +59,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, lw_optical_props_cnvclouds, & ! RRTMGP DDT: longwave convective cloud optical properties lw_optical_props_MYNNcloudsByBand ! RRTMGP DDT: longwave MYNN-EDMF PBL cloud optical properties ! Outputs - real(kind_phys), dimension(ncol,nLev+1), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & fluxlwUP_jac, & ! Jacobian of upwelling LW surface radiation (W/m2/K) fluxlwUP_allsky, & ! All-sky flux (W/m2) fluxlwDOWN_allsky, & ! All-sky flux (W/m2) diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index f889c318b..bac62fb13 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -420,9 +420,9 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw imfdeepcnv, & ! imfdeepcnv_gf, & ! imfdeepcnv_samf ! - integer,intent(in),dimension(ncol) :: & + integer,intent(in),dimension(:) :: & idxday ! Indices for daylit points. - real(kind_phys), dimension(ncol,nLev),intent(in) :: & + real(kind_phys), dimension(:,:),intent(in) :: & cld_frac, & ! Total cloud fraction by layer cld_lwp, & ! Cloud liquid water path cld_reliq, & ! Cloud liquid effective radius @@ -451,7 +451,7 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (convective cloud) sw_optical_props_MYNNcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (MYNN PBL cloud) sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (cloud precipitation) - real(kind_phys), dimension(ncol,NLev), intent(out) :: & + real(kind_phys), dimension(:,:), intent(out) :: & cldtausw ! Approx 10.mu band layer cloud optical depth ! Local variables diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 index b6c251166..1c1da46db 100644 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -45,18 +45,18 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, iovr_exp, & ! Flag for exponential cloud overlap method iovr_exprand, & ! Flag for exponential-random cloud overlap method isubc_sw - integer,intent(in),dimension(ncol) :: & + integer,intent(in),dimension(:) :: & idxday ! Indices for daylit points. - integer,intent(in),dimension(ncol) :: & + integer,intent(in),dimension(:) :: & icseed_sw ! auxiliary special cloud related array when module ! variable isubc_sw=2, it provides permutation seed ! for each column profile that are used for generating ! random numbers. when isubc_sw /=2, it will not be used. - real(kind_phys), dimension(ncol,nLev),intent(in) :: & + real(kind_phys), dimension(:,:),intent(in) :: & cld_frac, & ! Total cloud fraction by layer cld_cnv_frac, & ! Convective cloud fraction by layer precip_frac ! Precipitation fraction by layer - real(kind_phys), dimension(ncol,nLev), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & cloud_overlap_param, & ! Cloud overlap parameter cnv_cloud_overlap_param, & ! Convective cloud overlap parameter precip_overlap_param ! Precipitation overlap parameter diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index ddc3eacb1..4240e3f93 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -44,11 +44,11 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz nday, & ! Number of daytime points nLev, & ! Number of vertical levels iSFC ! Vertical index for surface-level - integer, intent(in), dimension(ncol) :: & + integer, intent(in), dimension(:) :: & idxday ! Index array for daytime points - real(kind_phys),intent(in), dimension(ncol) :: & + real(kind_phys),intent(in), dimension(:) :: & coszen ! Cosize of SZA - real(kind_phys), dimension(ncol,NLev), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & p_lay, & ! Pressure @ model layer-centers (Pa) t_lay ! Temperature (K) type(ty_optical_props_2str),intent(inout) :: & @@ -59,12 +59,11 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz sw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: shortwave MYNN-EDMF PBL cloud optical properties sw_optical_props_precip, & ! RRTMGP DDT: shortwave precipitation optical properties sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol optical properties - real(kind_phys), dimension(sw_gas_props%get_nband(),ncol), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & sfc_alb_nir_dir, & ! Surface albedo (direct) sfc_alb_nir_dif, & ! Surface albedo (diffuse) sfc_alb_uvvis_dir, & ! Surface albedo (direct) - sfc_alb_uvvis_dif ! Surface albedo (diffuse) - real(kind_phys), dimension(ncol,sw_gas_props%get_ngpt()), intent(in) :: & + sfc_alb_uvvis_dif, & ! Surface albedo (diffuse) toa_src_sw ! TOA incident spectral flux (W/m2) ! Outputs @@ -72,12 +71,12 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz errmsg ! CCPP error message integer, intent(out) :: & errflg ! CCPP error flag - real(kind_phys), dimension(ncol,NLev+1), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & fluxswUP_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2) fluxswDOWN_allsky, & ! RRTMGP downward all-sky flux profiles (W/m2) fluxswUP_clrsky, & ! RRTMGP upward clear-sky flux profiles (W/m2) fluxswDOWN_clrsky ! RRTMGP downward clear-sky flux profiles (W/m2) - type(cmpfsw_type), dimension(ncol), intent(inout) :: & + type(cmpfsw_type), dimension(:), intent(inout) :: & scmpsw ! 2D surface fluxes, components: ! uvbfc - total sky downward uv-b flux (W/m2) ! uvbf0 - clear sky downward uv-b flux (W/m2) From ba5b1f80db499108c0279d06c70f45a9eb722e84 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 10 Mar 2022 20:27:27 +0000 Subject: [PATCH 107/217] Bug from previous commit --- physics/GFS_rrtmgp_cloud_mp.F90 | 16 ++++++++-------- physics/GFS_rrtmgp_pre.F90 | 3 ++- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index acd63f483..53b4d801c 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -333,8 +333,8 @@ subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, ! Local integer :: iCol, iLay real(kind_phys) :: tem1, deltaP, clwc, qc, qi - real(kind_phys), parameter :: tem1 = 1.0e5/con_g + tem1 = 1.0e5/con_g do iLay = 1, nLev do iCol = 1, nCol if (qci_conv(iCol,iLay) > 0.) then @@ -344,8 +344,8 @@ subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, ! Compute LWP/IWP deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 - cld_cnv_lwp(iCol,iLay) = max(0., qc * tem1*deltaP) - cld_cnv_iwp(iCol,iLay) = max(0., qi * tem1*deltaP) + cld_cnv_lwp(iCol,iLay) = max(0., qc * tem1 * deltaP) + cld_cnv_iwp(iCol,iLay) = max(0., qi * tem1 * deltaP) ! Particle sizes if (nint(lsmask(iCol)) == 1) then !land @@ -409,8 +409,8 @@ subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum ! Local integer :: iCol, iLay real(kind_phys) :: tem1, qc, qi, deltaP - real(kind_phys), parameter :: tem1 = 1.0e5/con_g + tem1 = 1.0e5/con_g do iLay = 1, nLev do iCol = 1, nCol if (cld_pbl_frac(iCol,iLay) > cld_limit_lower) then @@ -565,9 +565,8 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai cld_rerain ! Cloud rain effective radius ! Local variables - real(kind_phys) :: tem2,tem3,pfac,deltaP + real(kind_phys) :: tem1,tem2,tem3,pfac,deltaP real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate - real(kind_phys), parameter :: tem1 = 1.0e5/con_g integer :: iCol,iLay,l,ncndl ! Cloud condensate @@ -580,6 +579,7 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai endif ! Cloud water path (g/m2) + tem1 = 1.0e5/con_g do iLay = 1, nLev do iCol = 1, nCol ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) @@ -698,9 +698,8 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c cld_rwp ! Cloud rain water path ! Local variables - real(kind_phys) :: pfac, cld_mr, deltaP + real(kind_phys) :: tem1, pfac, cld_mr, deltaP real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate - real(kind_phys), parameter :: tem1 = 1.0e5/con_g integer :: iCol,iLay,l ! Cloud condensate @@ -715,6 +714,7 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c cld_rwp(:,:) = 0.0 cld_swp(:,:) = 0.0 cld_frac(:,:) = 0.0 + tem1 = 1.0e5/con_g do iLay = 1, nLev-1 do iCol = 1, nCol ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index e7cb31ce5..53504c8dd 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -187,7 +187,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw real(kind_phys), dimension(nLev) :: hgtc real(kind_phys), dimension(nCol,nLev) :: o3_lay real(kind_phys), dimension(nCol,nLev, NF_VGAS) :: gas_vmr - real(kind_phys), parameter :: con_rdog = con_rd/con_g + real(kind_phys) :: con_rdog ! Initialize CCPP error handling variables errmsg = '' @@ -265,6 +265,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! Compute layer-thickness between layer boundaries (deltaZ) and layer centers (deltaZc) ! deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev)) + con_rdog = con_rd/con_g do iCol=1,nCol if (top_at_1) then ! Layer thickness (m) From 70507a0cdca6274e23943f9e96ac06750d7bf410 Mon Sep 17 00:00:00 2001 From: helin wei Date: Thu, 10 Mar 2022 22:23:34 +0000 Subject: [PATCH 108/217] to avoid exception floating point --- physics/module_sf_noahmplsm.f90 | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index c945e66ff..99b0cde7f 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -2507,8 +2507,12 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) - laimax = maxval(parameters%laim) - df(1) = df(1) * exp (sbeta * elai/laimax) + if(elai.gt.0.) then + laimax = maxval(parameters%laim) + laimax = min(laimax, 0.1) + + df(1) = df(1) * exp (sbeta * elai/laimax) + endif ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -5165,6 +5169,9 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur fv = ustarx laimax = maxval(parameters%laim) saimax = maxval(parameters%saim) + laimax = min(laimax, 0.1) + saimax = min(saimax, 0.1) + ! fv = ur*vkc/log((zlvl-zpd)/z0m) if(vegetated) then From d33598bb0079f56aeec3af97689fb24cb04049ba Mon Sep 17 00:00:00 2001 From: helin wei Date: Fri, 11 Mar 2022 16:28:53 +0000 Subject: [PATCH 109/217] revert the df1 change due to some negative impact on surface temperature --- physics/module_sf_noahmplsm.f90 | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 99b0cde7f..f9024c321 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -2041,7 +2041,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , elai, & !in + lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2431,7 +2431,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , elai, & !in + lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2456,7 +2456,6 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: lat !latitude (radians) real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) - real (kind=kind_phys), intent(in) :: elai !lai adjusted for burying by snow integer , intent(in) :: vegtyp !vegtyp type ! outputs @@ -2474,7 +2473,6 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) real (kind=kind_phys), dimension( 1:nsoil) :: sice !soil ice content real (kind=kind_phys), parameter :: sbeta = -2.0 - real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! -------------------------------------------------------------------------------------------------- ! compute snow thermal conductivity and heat capacity @@ -2507,12 +2505,6 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) - if(elai.gt.0.) then - laimax = maxval(parameters%laim) - laimax = min(laimax, 0.1) - - df(1) = df(1) * exp (sbeta * elai/laimax) - endif ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) From 71ab24d5a12a0e84d5802173c0526c9e1ed75e6c Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Fri, 11 Mar 2022 16:50:33 +0000 Subject: [PATCH 110/217] resolve the code conflicts --- physics/GFS_rrtmg_pre.F90 | 61 +++++++++++++++++++++++++++++++---- physics/GFS_rrtmg_pre.meta | 66 +++++++++++++++++++++++++++++++++++++- physics/radiation_clouds.f | 59 ++++++++++++++++++++++++++++++---- 3 files changed, 171 insertions(+), 15 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index c69ad7286..95cffa37d 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,8 +18,10 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, ntwa, ntoz, & - ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, & + ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & + imp_physics,imp_physics_nssl, nssl_ccn_on, nssl_invertccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & imp_physics_fer_hires, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & @@ -38,7 +40,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & - errmsg, errflg) + spp_wts_rad, spp_rad, errmsg, errflg) use machine, only: kind_phys @@ -83,7 +85,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv_gf, me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & ntcw, ntiw, ntlnc, ntinc, & - ntrw, ntsw, ntgl, ntwa, ntoz, & + ntrnc, ntsnc,ntccn, & + ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & kdt, imp_physics, & @@ -92,6 +95,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, & imp_physics_mg, imp_physics_wsm6, & + imp_physics_nssl, & imp_physics_fer_hires, & yearlen, icloud @@ -112,6 +116,10 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & uni_cld, effr_in, do_mynnedmf, & lmfshal, lmfdeep2, pert_clds + logical, intent(in) :: nssl_ccn_on, nssl_invertccn + integer, intent(in) :: spp_rad + real(kind_phys), intent(in) :: spp_wts_rad(:,:) + real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd @@ -654,7 +662,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ccnd(i,k,4) = tracer1(i,k,ntsw) ! snow water enddo enddo - elseif (ncnd == 5) then ! GFDL MP, Thompson, MG3, FA + elseif (ncnd == 5 .or. ncnd == 6) then ! GFDL MP, Thompson, MG3, NSSL do k=1,LMK do i=1,IM ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water @@ -663,7 +671,11 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & if (imp_physics == imp_physics_fer_hires ) then ccnd(i,k,4) = 0.0 else + IF ( ncnd == 5 ) THEN ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) ! snow + graupel + ELSEIF ( ncnd == 6 ) THEN + ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) + tracer1(i,k,nthl) ! snow + gr + ENDIF endif enddo enddo @@ -803,6 +815,23 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo endif + + elseif (imp_physics == imp_physics_nssl ) then ! NSSL MP + cldcov = 0.0 + if(effr_in) then + do k=1,lm + k1 = k + kd + do i=1,im + effrl(i,k1) = effrl_inout(i,k)! re_cloud (i,k) + effri(i,k1) = effri_inout(i,k)! re_ice (i,k) + effrr(i,k1) = effrr_in(i,k) + effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) + enddo + enddo + else + ! not used yet -- effr_in should always be true for now + endif + elseif (imp_physics == imp_physics_thompson) then ! Thompson MP ! ! Compute effective radii for QC, QI, QS with (GF, MYNN) or without (all others) sub-grid clouds @@ -898,8 +927,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & & xlat, xlon, slmsk, dz, delp, IM, LM, LMK, LMP, & & deltaq, sup, me, icloud, kdt, & & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & - & imp_physics, imp_physics_fer_hires,imp_physics_gfdl, & - & imp_physics_thompson, imp_physics_wsm6, & + & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & + & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & @@ -964,6 +993,24 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo + if ( spp_rad == 1 ) then + do k=1,lm + if (k < levs) then + do i=1,im + clouds3(i,k) = clouds3(i,k) - spp_wts_rad(i,k) * clouds3(i,k) + clouds5(i,k) = clouds5(i,k) - spp_wts_rad(i,k) * clouds5(i,k) + clouds9(i,k) = clouds9(i,k) - spp_wts_rad(i,k) * clouds9(i,k) + enddo + else + do i=1,im + clouds3(i,k) = clouds3(i,k) - spp_wts_rad(i,k) * clouds3(i,k) + clouds5(i,k) = clouds5(i,k) - spp_wts_rad(i,k) * clouds5(i,k) + clouds9(i,k) = clouds9(i,k) - spp_wts_rad(i,k) * clouds9(i,k) + enddo + endif + enddo + endif + ! mg, sfc-perts ! --- scale random patterns for surface perturbations with ! perturbation size diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 1983e8078..15bd94fb8 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -142,6 +142,20 @@ dimensions = () type = integer intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in [ntrw] standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array long_name = tracer index for rain water @@ -163,6 +177,20 @@ dimensions = () type = integer intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in +[ntccn] + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in [ntwa] standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array long_name = tracer index for water friendly aerosol @@ -177,6 +205,20 @@ dimensions = () type = integer intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = flag + dimensions = () + type = logical + intent = in [ntclamt] standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array long_name = tracer index for cloud amount integer @@ -226,6 +268,13 @@ dimensions = () type = integer intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme @@ -595,7 +644,7 @@ [sfc_wts] standard_name = surface_stochastic_weights_from_coupled_process long_name = weights for stochastic surface physics perturbation - units = none + units = 1 dimensions = (horizontal_loop_extent,number_of_perturbed_land_surface_variables) type = real kind = kind_phys @@ -1145,6 +1194,21 @@ type = real kind = kind_phys intent = out +[spp_wts_rad] + standard_name = spp_weights_for_radiation_scheme + long_name = spp weights for radiation scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spp_rad] + standard_name = control_for_radiation_spp_perturbations + long_name = control for radiation spp perturbations + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 4ee8b146a..16ea93d26 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -26,8 +26,8 @@ ! xlat,xlon,slmsk,dz,delp, IX, LM, NLAY, NLP1, ! ! deltaq, sup, me, icloud, kdt, ! ! ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, ! -! imp_physics, imp_physics_fer_hires,imp_physics_gfdl, ! -! imp_physics_thompson, imp_physics_wsm6, ! +! imp_physics, imp_physics_nssl, imp_physics_fer_hires, ! +! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, ! ! imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, ! ! imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, ! ! iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, ! @@ -273,6 +273,7 @@ module module_radiation_clouds !!\n =6: WSM6 microphysics !!\n =10: MG microphysics !!\n =15: Ferrier-Aligo microphysics +!!\n =17/18: NSSL microphysics !!\param me print control flag !>\section cld_init General Algorithm !! @{ @@ -363,6 +364,8 @@ subroutine cld_init & print *,' --- MG cloud microphysics' elseif (imp_physics == 15) then print *,' --- Ferrier-Aligo cloud microphysics' + elseif (imp_physics == 17) then + print *,' --- NSSL cloud microphysics' else print *,' !!! ERROR in cloud microphysc specification!!!', & & ' imp_physics (NP3D) =',imp_physics @@ -409,8 +412,8 @@ subroutine radiation_clouds_prop & & xlat, xlon, slmsk, dz, delp, IX, LM, NLAY, NLP1, & & deltaq, sup, me, icloud, kdt, & & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & - & imp_physics, imp_physics_fer_hires,imp_physics_gfdl, & - & imp_physics_thompson, imp_physics_wsm6, & + & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & + & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & @@ -495,6 +498,7 @@ subroutine radiation_clouds_prop & ! ntgl tracer index for graupel (Model%ntgl) ! ! ntclamt tracer index for cloud amount (Model%ntclamt) ! ! imp_physics : cloud microphysics scheme control flag ! +! imp_physics_nssl : NSSL microphysics ! ! imp_physics_fer_hires : Ferrier-Aligo microphysics scheme ! ! imp_physics_gfdl : GFDL microphysics scheme ! ! imp_physics_thompson : Thompson microphysics scheme ! @@ -579,6 +583,7 @@ subroutine radiation_clouds_prop & integer, intent(in) :: kdt, imfdeepcnv, imfdeepcnv_gf integer, intent(in) :: & & imp_physics, ! Flag for MP scheme + & imp_physics_nssl, ! Flag for NSSL scheme & imp_physics_fer_hires, ! Flag for fer-hires scheme & imp_physics_gfdl, ! Flag for gfdl scheme & imp_physics_thompson, ! Flag for thompsonscheme @@ -760,6 +765,45 @@ subroutine radiation_clouds_prop & & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) + elseif ( imp_physics == imp_physics_nssl ) then ! NSSL MP + + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + !-- MYNN PBL or convective GF + !-- use cloud fractions with SGS clouds + do k=1,NLAY + do i=1,IX + cld_frac(i,k) = clouds1(i,k) + enddo + enddo + + ! --- use clduni with the NSSL microphysics. + ! --- make sure that effr_in=.true. in the input.nml! + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + & xlat, xlon, slmsk, dz, delp, IX, NLAY, NLP1, & + & cld_frac, & + & effrl, effri, effrr, effrs, effr_in , & + & dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + else + ! MYNN PBL or GF convective are not used + call progcld_thompson_wsm6 (plyr,plvl,tlyr,qlyr,qstl, & ! --- inputs + & rhly,tracer1,xlat,xlon,slmsk,dz,delp, & + & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + & ntsw-1,ntgl-1, & + & IX, NLAY, NLP1, uni_cld, lmfshal, lmfdeep2, & + & cldcov(:,1:NLAY), cnvw, effrl_inout, & + & effri_inout, effrs_inout, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + endif ! MYNN PBL or GF + elseif(imp_physics == imp_physics_thompson) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv @@ -2014,7 +2058,7 @@ end subroutine progcld_fer_hires !................................... -! This subroutine is used by Thompson/wsm6 cloud microphysics (EMC) +! This subroutine is used by Thompson/WSM6/NSSL cloud microphysics (EMC) subroutine progcld_thompson_wsm6 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & @@ -2030,8 +2074,9 @@ subroutine progcld_thompson_wsm6 & ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld_thompson_wsm6 computes cloud related quantities using ! -! Thompson/WSM6 cloud microphysics scheme. ! +! subprogram: progcld_thompson_wsm6 ! +! computes cloud related quantities using ! +! Thompson/WSM6/NSSL cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! ! condensates, ! From d3ff8f692014cdf398aa56e592cf939ca49bb413 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 11 Mar 2022 12:55:06 -0700 Subject: [PATCH 111/217] SPP bugfix from Jeff Beck --- physics/GFS_rrtmg_pre.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 1763ca0b1..c45cb2b98 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -1002,9 +1002,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo else do i=1,im - clouds3(i,k) = clouds3(i,k) - spp_wts_rad(i,k) * clouds3(i,k) - clouds5(i,k) = clouds5(i,k) - spp_wts_rad(i,k) * clouds5(i,k) - clouds9(i,k) = clouds9(i,k) - spp_wts_rad(i,k) * clouds9(i,k) + clouds3(i,k) = clouds3(i,k) - spp_wts_rad(i,levs) * clouds3(i,k) + clouds5(i,k) = clouds5(i,k) - spp_wts_rad(i,levs) * clouds5(i,k) + clouds9(i,k) = clouds9(i,k) - spp_wts_rad(i,levs) * clouds9(i,k) enddo endif enddo From a31d08bdd46b7d88efe52d3523c85db1983b2021 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Fri, 11 Mar 2022 20:42:20 +0000 Subject: [PATCH 112/217] Added capability for cdmbgwd(1) to scale GSL blocking drag --- physics/drag_suite.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 7fea98b13..b4bd4e4d9 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -531,7 +531,8 @@ subroutine drag_suite_run( & ! non-dim sub grid mtn drag Amp (*j*) ! cdmb = 1.0/float(IMX/192) ! cdmb = 192.0/float(IMX) - cdmb = 4.0 * 192.0/float(IMX) + ! New cdmbgwd addition for GSL blocking drag + cdmb = 1.0 if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) !>-# Orographic Gravity Wave Drag Section @@ -1237,7 +1238,8 @@ subroutine drag_suite_run( & !--------- compute flow-blocking stress ! cd = max(2.0-1.0/od(i),0.0) - taufb(i,kts) = 0.5 * roll(i) * coefm(i) / & + ! New cdmbgwd addition for GSL blocking drag + taufb(i,kts) = cdmb * 0.5 * roll(i) * coefm(i) / & max(dxmax_ls,dxy(i))**2 * cd * dxyp(i) * & olp(i) * zblk * ulow(i)**2 tautem = taufb(i,kts)/float(kblk-kts) From 44ca4f04365f20e58205a6966213af76ba6d0907 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 11 Mar 2022 16:10:46 -0700 Subject: [PATCH 113/217] add Chunxi Zhang to CODEOWNERS --- CODEOWNERS | 160 ++++++++++++++++++++++++++--------------------------- 1 file changed, 80 insertions(+), 80 deletions(-) diff --git a/CODEOWNERS b/CODEOWNERS index a9728c5b9..c845e7f97 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -4,125 +4,125 @@ # Default codeowners for files that don't have specific owners: -* @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +* @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA # The following lines are from the CCPP Primary Schemes Points of Contact # https://docs.google.com/spreadsheets/d/14y0Th_sSpCqlssEMNfSZ_Ni9wrpPqfpPY0kRG7jCZB8/edit#gid=0 # (Internal NOAA document.) -physics/cs_conv_aw_adj.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/cs_conv.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/cu_gf* @hannahcbarnes @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/sascnvn.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/cs_conv_aw_adj.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/cs_conv.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/cu_gf* @hannahcbarnes @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/sascnvn.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA physics/cu_ntiedtke* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/rascnv.* @SMoorthi-emc @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/rascnv.* @SMoorthi-emc @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/samfdeepcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/samfshalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/samfaerosols.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/samfdeepcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/samfshalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/samfaerosols.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/shalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/unified_ugwp* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/ugwp_driver_v0.F @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/cires_ugwp* @mdtoyNOAA @ValeryYudin-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/drag_suite.* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/shalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/unified_ugwp* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/ugwp_driver_v0.F @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/cires_ugwp* @mdtoyNOAA @ValeryYudin-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/drag_suite.* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gwdc.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/gwdps.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/gwdc.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/gwdps.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gfdl_fv_sat_adj.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/gfdl_fv_sat_adj.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/multi_gases.F90 @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/module_gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/multi_gases.F90 @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mp_fer_hires.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/module_MP_FER_HIRES.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/mp_fer_hires.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/module_MP_FER_HIRES.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/precpd.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/gscond.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/precpd.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/gscond.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/m_micro* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/m_micro* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/ozphys* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/ozphys* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/satmedmfvdif.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/satmedmfvdifq.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/mfpbl.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/mfscu.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/mfpbltq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/mfscuq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/satmedmfvdif.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/satmedmfvdifq.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/mfpbl.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/mfscu.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/mfpbltq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/mfscuq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA physics/shinhongvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich physics/ysuvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @JongilHan66 @WeiguoWang-NOAA @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/moninedmf.* @JongilHan66 @WeiguoWang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/moninedmf.* @JongilHan66 @WeiguoWang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_BL_MYJPBL.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/module_MYJPBL_wrapper.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/module_BL_MYJPBL.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/module_MYJPBL_wrapper.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_bl_mynn.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/module_MYNNPBL_wrapper.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/module_bl_mynn.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/module_MYNNPBL_wrapper.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gcm_shoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/moninshoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/gcm_shoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/moninshoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rte-rrtmgp @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/radiation_tools.* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/rrtmgp_lw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/rrtmgp_sw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/rte-rrtmgp @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/radiation_tools.* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/rrtmgp_lw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/rrtmgp_sw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radlw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/HWRF_mcica_random_numbers.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/HWRF_mersenne_twister.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/radlw_datatb.f @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/radsw_datatb.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/radsw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/radlw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/HWRF_mcica_random_numbers.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/HWRF_mersenne_twister.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/radlw_datatb.f @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/radsw_datatb.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/radsw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radsw_param.f @dustinswales @Qingfu-Liu @mjiacono @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/radsw_param.f @dustinswales @Qingfu-Liu @mjiacono @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rayleigh_damp.* @yangfanglin @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/flake* @YihuaWu-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/rayleigh_damp.* @yangfanglin @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/flake* @YihuaWu-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_drv.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/sflx.f @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/surface_perturbation.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/sfc_drv.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/sflx.f @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/surface_perturbation.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/*noahmp* @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/*noahmp* @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/namelist_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/set_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/module_sf_ruclsm.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/module_soil_pre.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/sfc_drv_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/namelist_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/set_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/module_sf_ruclsm.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/module_soil_pre.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/sfc_drv_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/date_def.f @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/*nst* @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/date_def.f @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/*nst* @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_ocean.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/sfc_diff.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/sfc_ocean.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/sfc_diff.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/h2ophys.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/h2ophys.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_sice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/sfc_cice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/sfc_sice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/sfc_cice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA ######################################################################## From 3095d719239fbc804d632eeca711e7d5ed2680fd Mon Sep 17 00:00:00 2001 From: helin wei Date: Mon, 14 Mar 2022 21:06:18 +0000 Subject: [PATCH 114/217] correct the condition to avoid a divide by zero exception --- physics/module_sf_noahmplsm.f90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index f9024c321..1460e61f4 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -5151,7 +5151,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys) :: czil1 ! canopy based czil real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output real (kind=kind_phys) :: sigmaa ! momentum partition parameter - real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx + real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx,slaifrac real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided @@ -5161,8 +5161,12 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur fv = ustarx laimax = maxval(parameters%laim) saimax = maxval(parameters%saim) - laimax = min(laimax, 0.1) - saimax = min(saimax, 0.1) + + if(laimax+saimax .gt. 0) then + slaifrac=vaie/(laimax+saimax) + else + slaifrac=0.1_kind_phys + endif ! fv = ur*vkc/log((zlvl-zpd)/z0m) @@ -5214,7 +5218,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(vaie/(laimax+saimax), 0.1_kind_phys) + tem2 = max(slaifrac, 0.1_kind_phys) zvfun1 = sqrt(tem1 * tem2) gdx = sqrt(garea1) From 27ea849d8e88c70f6e3a1d014a0c85d0dd6ef2b9 Mon Sep 17 00:00:00 2001 From: helin wei Date: Tue, 15 Mar 2022 13:25:51 +0000 Subject: [PATCH 115/217] further refinement of the impact of vegetation on zvfun --- physics/module_sf_noahmplsm.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 1460e61f4..360536ec3 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -5164,6 +5164,8 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur if(laimax+saimax .gt. 0) then slaifrac=vaie/(laimax+saimax) + slaifrac=min(slaifrac,1.) + slaifrac=fveg*slaifrac else slaifrac=0.1_kind_phys endif From c34da796bed574ce96fdbe3ba32706fe7961fc00 Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Tue, 15 Mar 2022 13:34:07 +0000 Subject: [PATCH 116/217] Properly set the total number of species to be diffused in the PBL for Thompson microphysics scheme when coupling with prognostic aerosols (#880). --- physics/GFS_PBL_generic.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index aae7d72ec..8d013a442 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -37,9 +37,9 @@ subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & elseif (imp_physics == imp_physics_thompson) then ! Thompson if(ltaerosol) then - kk = 10 + kk = 12 else - kk = 7 + kk = 9 endif ! MG elseif (imp_physics == imp_physics_mg) then From 54a57baa8d8874a09081cd3b51fc9dc4d53ad4e8 Mon Sep 17 00:00:00 2001 From: "Chunxi.Zhang-NOAA" Date: Tue, 15 Mar 2022 14:28:24 +0000 Subject: [PATCH 117/217] P8C updates: the TKE-EDMF PBL scheme and the saSAS cumulus scheme --- physics/mfpbltq.f | 28 ++++++++----- physics/mfscuq.f | 28 ++++++++----- physics/samfdeepcnv.f | 88 +++++++++++++++++++++++++++++++++++------ physics/samfshalcnv.f | 83 ++++++++++++++++++++++++++++++-------- physics/satmedmfvdifq.F | 78 ++++++++++++++++++++++++++++++++++-- 5 files changed, 253 insertions(+), 52 deletions(-) diff --git a/physics/mfpbltq.f b/physics/mfpbltq.f index b906052cd..a0788d5b7 100644 --- a/physics/mfpbltq.f +++ b/physics/mfpbltq.f @@ -11,7 +11,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, & gdx,hpbl,kpbl,vpert,buo,xmf, - & tcko,qcko,ucko,vcko,xlamue,a1) + & tcko,qcko,ucko,vcko,xlamueq,a1) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -35,14 +35,15 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & buo(im,km), xmf(im,km), & tcko(im,km),qcko(im,km,ntrac1), & ucko(im,km),vcko(im,km), - & xlamue(im,km-1) + & xlamueq(im,km-1) ! c local variables and arrays ! integer i, j, k, n, ndc integer kpblx(im), kpbly(im) ! - real(kind=kind_phys) dt2, dz, ce0, cm, + real(kind=kind_phys) dt2, dz, ce0, + & cm, cq, & factor, gocp, & g, b1, f1, & bb1, bb2, @@ -56,7 +57,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & thup, thvu, dq ! real(kind=kind_phys) rbdn(im), rbup(im), hpblx(im), - & xlamuem(im,km-1) + & xlamue(im,km-1), xlamuem(im,km-1) real(kind=kind_phys) delz(im), xlamax(im) ! real(kind=kind_phys) wu2(im,km), thlu(im,km), @@ -71,7 +72,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, parameter(g=grav) parameter(gocp=g/cp) parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) - parameter(ce0=0.4,cm=1.0) + parameter(ce0=0.4,cm=1.0,cq=1.3) parameter(qmin=1.e-8,qlmin=1.e-12) parameter(alp=1.5,vpertmax=3.0,pgcon=0.55) parameter(b1=0.5,f1=0.15) @@ -132,6 +133,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, xlamue(i,k) = xlamax(i) endif ! + xlamueq(i,k) = cq * xlamue(i,k) xlamuem(i,k) = cm * xlamue(i,k) endif enddo @@ -148,6 +150,9 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem* & (thlx(i,k-1)+thlx(i,k)))/factor +! + tem = 0.5 * xlamueq(i,k-1) * dz + factor = 1. + tem qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem* & (qtx(i,k-1)+qtx(i,k)))/factor ! @@ -282,6 +287,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, xlamue(i,k) = xlamax(i) endif ! + xlamueq(i,k) = cq * xlamue(i,k) xlamuem(i,k) = cm * xlamue(i,k) endif enddo @@ -313,7 +319,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, do k = 1, kmpbl do i = 1, im if (cnvflg(i) .and. k < kpbl(i)) then - xmf(i,k) = a1 * sqrt(wu2(i,k)) + xmf(i,k) = sqrt(wu2(i,k)) endif enddo enddo @@ -350,7 +356,8 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, do k = 1, kmpbl do i = 1, im if (cnvflg(i) .and. k < kpbl(i)) then - xmf(i,k) = scaldfunc(i) * xmf(i,k) + tem = max(a1, sigma(i)) + xmf(i,k) = scaldfunc(i) * tem * xmf(i,k) dz = zl(i,k+1) - zl(i,k) xmmx = dz / dt2 xmf(i,k) = min(xmf(i,k),xmmx) @@ -384,6 +391,9 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem* & (thlx(i,k-1)+thlx(i,k)))/factor +! + tem = 0.5 * xlamueq(i,k-1) * dz + factor = 1. + tem qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem* & (qtx(i,k-1)+qtx(i,k)))/factor ! @@ -432,7 +442,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, do i = 1, im if (cnvflg(i) .and. k <= kpbl(i)) then dz = zl(i,k) - zl(i,k-1) - tem = 0.5 * xlamue(i,k-1) * dz + tem = 0.5 * xlamueq(i,k-1) * dz factor = 1. + tem ! qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* @@ -453,7 +463,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, do i = 1, im if (cnvflg(i) .and. k <= kpbl(i)) then dz = zl(i,k) - zl(i,k-1) - tem = 0.5 * xlamue(i,k-1) * dz + tem = 0.5 * xlamueq(i,k-1) * dz factor = 1. + tem ! qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* diff --git a/physics/mfscuq.f b/physics/mfscuq.f index 3390c3e58..b41ffd13e 100644 --- a/physics/mfscuq.f +++ b/physics/mfscuq.f @@ -11,7 +11,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix, & thlx,thvx,thlvx,gdx,thetae, & krad,mrad,radmin,buo,xmfd, - & tcdo,qcdo,ucdo,vcdo,xlamde,a1) + & tcdo,qcdo,ucdo,vcdo,xlamdeq,a1) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -39,7 +39,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, & buo(im,km), xmfd(im,km), & tcdo(im,km), qcdo(im,km,ntrac1), & ucdo(im,km), vcdo(im,km), - & xlamde(im,km-1) + & xlamdeq(im,km-1) ! ! local variables and arrays ! @@ -47,7 +47,8 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, integer i,j,indx, k, n, kk, ndc integer krad1(im) ! - real(kind=kind_phys) dt2, dz, ce0, cm, + real(kind=kind_phys) dt2, dz, ce0, + & cm, cq, & gocp, factor, g, tau, & b1, f1, bb1, bb2, & a1, a2, @@ -62,7 +63,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, ! real(kind=kind_phys) wd2(im,km), thld(im,km), & qtx(im,km), qtd(im,km), - & thlvd(im), hrad(im), + & thlvd(im), hrad(im), xlamde(im,km-1), & xlamdem(im,km-1), ra1(im) real(kind=kind_phys) delz(im), xlamax(im) ! @@ -77,7 +78,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, parameter(g=grav) parameter(gocp=g/cp) parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) - parameter(ce0=0.4,cm=1.0,pgcon=0.55) + parameter(ce0=0.4,cm=1.0,cq=1.3,pgcon=0.55) parameter(qmin=1.e-8,qlmin=1.e-12) parameter(b1=0.45,f1=0.15) parameter(a2=0.5) @@ -208,6 +209,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, xlamde(i,k) = xlamax(i) endif ! + xlamdeq(i,k) = cq * xlamde(i,k) xlamdem(i,k) = cm * xlamde(i,k) endif enddo @@ -224,6 +226,9 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, ! thld(i,k) = ((1.-tem)*thld(i,k+1)+tem* & (thlx(i,k)+thlx(i,k+1)))/factor +! + tem = 0.5 * xlamdeq(i,k) * dz + factor = 1. + tem qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem* & (qtx(i,k)+qtx(i,k+1)))/factor ! @@ -347,6 +352,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, xlamde(i,k) = xlamax(i) endif ! + xlamdeq(i,k) = cq * xlamde(i,k) xlamdem(i,k) = cm * xlamde(i,k) endif enddo @@ -380,7 +386,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, do i = 1, im if(cnvflg(i) .and. & (k >= mrad(i) .and. k < krad(i))) then - xmfd(i,k) = ra1(i) * sqrt(wd2(i,k)) + xmfd(i,k) = sqrt(wd2(i,k)) endif enddo enddo @@ -418,7 +424,8 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, do i = 1, im if(cnvflg(i) .and. & (k >= mrad(i) .and. k < krad(i))) then - xmfd(i,k) = scaldfunc(i) * xmfd(i,k) + tem = max(ra1(i), sigma(i)) + xmfd(i,k) = scaldfunc(i) * tem * xmfd(i,k) dz = zl(i,k+1) - zl(i,k) xmmx = dz / dt2 xmfd(i,k) = min(xmfd(i,k),xmmx) @@ -457,6 +464,9 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, ! thld(i,k) = ((1.-tem)*thld(i,k+1)+tem* & (thlx(i,k)+thlx(i,k+1)))/factor +! + tem = 0.5 * xlamdeq(i,k) * dz + factor = 1. + tem qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem* & (qtx(i,k)+qtx(i,k+1)))/factor ! @@ -509,7 +519,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, if (cnvflg(i) .and. k < krad(i)) then if(k >= mrad(i)) then dz = zl(i,k+1) - zl(i,k) - tem = 0.5 * xlamde(i,k) * dz + tem = 0.5 * xlamdeq(i,k) * dz factor = 1. + tem ! qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* @@ -532,7 +542,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, if (cnvflg(i) .and. k < krad(i)) then if(k >= mrad(i)) then dz = zl(i,k+1) - zl(i,k) - tem = 0.5 * xlamde(i,k) * dz + tem = 0.5 * xlamdeq(i,k) * dz factor = 1. + tem ! qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 3801e684f..0420fa1d2 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -149,16 +149,16 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & dh, dhh, dp, & dq, dqsdp, dqsdt, dt, & dt2, dtmax, dtmin, - & dxcrtas, dxcrtuf, +! & dxcrtas, dxcrtuf, dxcrtc0, + & dxcrtas, dxcrtuf, & dv1h, dv2h, dv3h, - & dv2q, & dz, dz1, e1, edtmax, & edtmaxl, edtmaxs, el2orc, elocp, & es, etah, & cthk, dthk, ! & evfact, evfactl, & fact1, fact2, factor, - & gamma, pprime, cm, + & gamma, pprime, cm, cq, & qlk, qrch, qs, & rain, rfact, shear, tfac, & val, val1, val2, @@ -225,7 +225,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! Until a realistic Nccn is provided, Nccns are assumed ! as Nccn=100 for sea and Nccn=1000 for land ! - parameter(cm=1.0) + parameter(cm=1.0,cq=1.3) ! parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) parameter(clamd=0.03,tkemx=0.65,tkemn=0.05) parameter(clamca=0.03) @@ -236,6 +236,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & parameter(cinacrmx=-120.,cinacrmn=-80.) parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) parameter(betaw=.03,dxcrtas=8.e3,dxcrtuf=15.e3) +! parameter(dxcrtc0=9.e3) ! ! local variables and arrays @@ -249,8 +250,12 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & wet_dep ! ! for updraft velocity calculation - real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km) - real(kind=kind_phys) wc(im), scaldfunc(im), sigmagfm(im) + real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km), + & wc(im) +! +! for updraft fraction & scale-aware function +! real(kind=kind_phys) scaldfunc(im), sigmagfm(im), xlamumean(im) + real(kind=kind_phys) scaldfunc(im), sigmagfm(im) ! c cloud water ! real(kind=kind_phys) tvo(im,km) @@ -392,6 +397,16 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & c0(i) = c0s endif enddo +! +!> - determine scale-aware rain conversion parameter decreasing with decreasing grid size +! do i=1,im +! if(gdx(i) < dxcrtc0) then +! tem = gdx(i) / dxcrtc0 +! tem1 = tem**2 +! c0(i) = c0(i) * tem1 +! endif +! enddo +! !> - determine rain conversion parameter above the freezing level which exponentially decreases with decreasing temperature from Han et al.'s (2017) \cite han_et_al_2017 equation 8. do k = 1, km do i = 1, im @@ -1013,6 +1028,33 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & enddo enddo endif +! +! compute mean entrainment rate in subcloud layers below cloud base +! +! do i= 1, im +! if(cnvflg(i)) then +! sumx(i) = 0. +! xlamumean(i) = 0. +! endif +! enddo +! do k = 1, km1 +! do i = 1, im +! if(cnvflg(i)) then +! if(k >= kb(i) .and. k < kbcon(i)) then +! dz = zi(i,k+1) - zi(i,k) +! tem = 0.5 * (xlamue(i,k)+xlamue(i,k+1)) +! xlamumean(i) = xlamumean(i) + tem * dz +! sumx(i) = sumx(i) + dz +! endif +! endif +! enddo +! enddo +! +! do i= 1, im +! if(cnvflg(i)) then +! xlamumean(i) = xlamumean(i) / sumx(i) +! endif +! enddo c c specify detrainment rate for the updrafts c @@ -1192,6 +1234,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(k > kb(i) .and. k < kmax(i)) then dz = zi(i,k) - zi(i,k-1) tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem factor = 1. + tem ecko(i,k,n) = ((1.-tem)*ecko(i,k-1,n)+tem* & (ctro(i,k,n)+ctro(i,k-1,n)))/factor @@ -1209,6 +1252,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(k > kb(i) .and. k < kmax(i)) then dz = zi(i,k) - zi(i,k-1) tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem factor = 1. + tem ecko(i,k,kk) = ((1. - tem) * ecko(i,k-1,kk) + tem * & (ctro(i,k,kk) + ctro(i,k-1,kk))) / factor @@ -1461,6 +1505,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & cj tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + tem = cq * tem + tem1 = cq * tem1 factor = 1. + tem - tem1 qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* & (qo(i,k)+qo(i,k-1)))/factor @@ -1636,6 +1682,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & cj tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + tem = cq * tem + tem1 = cq * tem1 factor = 1. + tem - tem1 qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* & (qo(i,k)+qo(i,k-1)))/factor @@ -1926,6 +1974,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if (cnvflg(i) .and. k < jmin(i)) then dz = zi(i,k+1) - zi(i,k) tem = 0.5 * xlamde * dz + tem = cq * tem factor = 1. + tem ecdo(i,k,n) = ((1.-tem)*ecdo(i,k+1,n)+tem* & (ctro(i,k,n)+ctro(i,k+1,n)))/factor @@ -1952,6 +2001,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & tem = xlamde * dz tem1 = 0.5 * (xlamd(i)+xlamdd) * dz endif + tem = cq * tem + tem1 = cq * tem1 factor = 1. + tem - tem1 qcdo(i,k) = ((1.-tem1)*qrcdo(i,k+1)+tem*0.5* & (qo(i,k)+qo(i,k+1)))/factor @@ -2084,7 +2135,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & dv1h = heo(i,k) dv2h = .5 * (heo(i,k) + heo(i,k-1)) dv3h = heo(i,k-1) - dv2q = .5 * (qo(i,k) + qo(i,k-1)) c tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) tem1 = 0.5 * (xlamud(i,k)+xlamud(i,k-1)) @@ -2107,11 +2157,12 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & + adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1))*dz & ) * factor cj + tem1 = -eta(i,k) * qrcko(i,k) + tem2 = -eta(i,k-1) * qcko(i,k-1) + ptem1 = -etad(i,k) * qrcdo(i,k) + ptem2 = -etad(i,k-1) * qcdo(i,k-1) dellaq(i,k) = dellaq(i,k) + - & (- (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2q*dz - & + aup*tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz - & + adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qcdo(i,k-1))*dz - & ) * factor + & (aup*(tem1-tem2)-adw*edto(i)*(ptem1-ptem2))*factor cj tem1=eta(i,k)*(uo(i,k)-ucko(i,k)) tem2=eta(i,k-1)*(uo(i,k-1)-ucko(i,k-1)) @@ -2502,6 +2553,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & cj tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + tem = cq * tem + tem1 = cq * tem1 factor = 1. + tem - tem1 qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* & (qo(i,k)+qo(i,k-1)))/factor @@ -2596,6 +2649,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & tem = xlamde * dz tem1 = 0.5 * (xlamd(i)+xlamdd) * dz endif + tem = cq * tem + tem1 = cq * tem1 factor = 1. + tem - tem1 qcdo(i,k) = ((1.-tem1)*qrcd(i,k+1)+tem*0.5* & (qo(i,k)+qo(i,k+1)))/factor @@ -2775,7 +2830,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! tfac = tauadv(i) / dtconv(i) ! tfac = min(tfac, 1.) ! xmb(i) = tfac*betaw*rho*wc(i) - xmb(i) = betaw*rho*wc(i) +! xmb(i) = betaw*rho*wc(i) + xmb(i) = rho*wc(i) endif enddo !> - For the cases where the quasi-equilibrium assumption of Arakawa-Schubert is valid, first calculate the large scale destabilization as in equation 5 of Pan and Wu (1995) \cite pan_and_wu_1995 : @@ -2836,6 +2892,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im if(cnvflg(i)) then tem = min(max(xlamx(i), 7.e-5), 3.e-4) +! tem = min(max(xlamumean(i), 1.e-4), 1.e-3) tem = 0.2 / tem tem1 = 3.14 * tem * tem sigmagfm(i) = tem1 / garea(i) @@ -2865,7 +2922,12 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & else scaldfunc(i) = 1.0 endif - xmb(i) = xmb(i) * scaldfunc(i) + if(asqecflg(i)) then + xmb(i) = xmb(i) * scaldfunc(i) + else + tem = max(betaw, sigmagfm(i)) + xmb(i) = tem * xmb(i) * scaldfunc(i) + endif xmb(i) = min(xmb(i),xmbmax(i)) endif enddo diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 0e11ed49c..68b12d169 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -102,12 +102,13 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & c0l, d0, & desdt, dp, & dq, dqsdp, dqsdt, dt, - & dt2, dtmax, dtmin, dxcrt, + & dt2, dtmax, dtmin, + & dxcrt, dxcrtc0, & dv1h, dv2h, dv3h, - & dv2q, & dz, dz1, e1, - & el2orc, elocp, aafac, cm, - & es, etah, h1, + & el2orc, elocp, aafac, + & cm, cq, + & es, etah, h1, shevf, ! & evfact, evfactl, & fact1, fact2, factor, dthk, & gamma, pprime, betaw, @@ -172,16 +173,17 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! Until a realistic Nccn is provided, Nccns are assumed ! as Nccn=100 for sea and Nccn=1000 for land ! - parameter(cm=1.0) + parameter(cm=1.0,cq=1.3) ! parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) parameter(clamd=0.1,tkemx=0.65,tkemn=0.05) parameter(dtke=tkemx-tkemn) parameter(dthk=25.,sfclfac=0.2,rhcrt=0.75) parameter(cinpcrmx=180.,cinpcrmn=120.) - parameter(cinacrmx=-120.) +! shevf is an enhancing evaporation factor for shallow convection + parameter(cinacrmx=-120.,shevf=1.0) parameter(dtmax=10800.,dtmin=600.) parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) - parameter(betaw=.03,dxcrt=15.e3) + parameter(betaw=.03,dxcrt=15.e3,dxcrtc0=9.e3) parameter(h1=0.33333333) c local variables and arrays real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), @@ -195,8 +197,12 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys), parameter :: escav = 0.8 ! wet scavenging efficiency ! ! for updraft velocity calculation - real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km) - real(kind=kind_phys) wc(im), scaldfunc(im), sigmagfm(im) + real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km), + & wc(im) +! +! for updraft fraction & scale-aware function +! real(kind=kind_phys) scaldfunc(im), sigmagfm(im), xlamumean(im) + real(kind=kind_phys) scaldfunc(im), sigmagfm(im) ! c cloud water ! real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), @@ -337,6 +343,15 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif enddo ! +!> - determine scale-aware rain conversion parameter decreasing with decreasing grid size + do i=1,im + if(gdx(i) < dxcrtc0) then + tem = gdx(i) / dxcrtc0 + tem1 = tem**3 + c0(i) = c0(i) * tem1 + endif + enddo +! !> - determine rain conversion parameter above the freezing level which exponentially decreases with decreasing temperature from Han et al.'s (2017) \cite han_et_al_2017 equation 8. do k = 1, km do i = 1, im @@ -889,6 +904,33 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif enddo endif ! hwrf_samfshal +! +! compute mean entrainment rate in subcloud layers below cloud base +! +! do i= 1, im +! if(cnvflg(i)) then +! sumx(i) = 0. +! xlamumean(i) = 0. +! endif +! enddo +! do k = 1, km1 +! do i = 1, im +! if(cnvflg(i)) then +! if(k >= kb(i) .and. k < kbcon(i)) then +! dz = zi(i,k+1) - zi(i,k) +! tem = 0.5 * (xlamue(i,k)+xlamue(i,k+1)) +! xlamumean(i) = xlamumean(i) + tem * dz +! sumx(i) = sumx(i) + dz +! endif +! endif +! enddo +! enddo +! +! do i= 1, im +! if(cnvflg(i)) then +! xlamumean(i) = xlamumean(i) / sumx(i) +! endif +! enddo c c determine updraft mass flux for the subcloud layers c @@ -996,6 +1038,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(k > kb(i) .and. k < kmax(i)) then dz = zi(i,k) - zi(i,k-1) tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem factor = 1. + tem ecko(i,k,n) = ((1.-tem)*ecko(i,k-1,n)+tem* & (ctro(i,k,n)+ctro(i,k-1,n)))/factor @@ -1013,6 +1056,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(k > kb(i) .and. k < kmax(i)) then dz = zi(i,k) - zi(i,k-1) tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem factor = 1. + tem ecko(i,k,kk) = ((1. - tem) * ecko(i,k-1,kk) + tem * & (ctro(i,k,kk) + ctro(i,k-1,kk))) / factor @@ -1194,6 +1238,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & cj tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz tem1 = 0.5 * xlamud(i) * dz + tem = cq * tem + tem1 = cq * tem1 factor = 1. + tem - tem1 qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* & (qo(i,k)+qo(i,k-1)))/factor @@ -1360,6 +1406,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & cj tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz tem1 = 0.5 * xlamud(i) * dz + tem = cq * tem + tem1 = cq * tem1 factor = 1. + tem - tem1 qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* & (qo(i,k)+qo(i,k-1)))/factor @@ -1565,7 +1613,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & dv1h = heo(i,k) dv2h = .5 * (heo(i,k) + heo(i,k-1)) dv3h = heo(i,k-1) - dv2q = .5 * (qo(i,k) + qo(i,k-1)) c tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) tem1 = xlamud(i) @@ -1578,10 +1625,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & + tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz & ) * factor cj - dellaq(i,k) = dellaq(i,k) + - & ( - tem*eta(i,k-1)*dv2q*dz - & + tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz - & ) * factor + tem1 = -eta(i,k) * qrcko(i,k) + tem2 = -eta(i,k-1) * qcko(i,k-1) + dellaq(i,k) = dellaq(i,k) + (tem1-tem2) * factor cj tem1=eta(i,k)*(uo(i,k)-ucko(i,k)) tem2=eta(i,k-1)*(uo(i,k-1)-ucko(i,k-1)) @@ -1813,7 +1859,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! tfac = tauadv(i) / dtconv(i) ! tfac = min(tfac, 1.) ! xmb(i) = tfac*betaw*rho*wc(i) - xmb(i) = betaw*rho*wc(i) +! xmb(i) = betaw*rho*wc(i) + xmb(i) = rho*wc(i) endif enddo ! @@ -1821,6 +1868,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im if(cnvflg(i)) then tem = min(max(xlamue(i,kbcon(i)), 2.e-4), 6.e-4) +! tem = min(max(xlamumean(i), 2.e-4), 2.e-3) tem = 0.2 / tem tem1 = 3.14 * tem * tem sigmagfm(i) = tem1 / garea(i) @@ -1838,7 +1886,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & else scaldfunc(i) = 1.0 endif - xmb(i) = xmb(i) * scaldfunc(i) + tem = max(betaw, sigmagfm(i)) + xmb(i) = tem * xmb(i) * scaldfunc(i) xmb(i) = min(xmb(i),xmbmax(i)) endif enddo @@ -2145,7 +2194,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! evef = edt(i) * evfact ! if(islimsk(i) == 1) evef=edt(i) * evfactl ! if(islimsk(i) == 1) evef=.07 - qcond(i) = evef * (q1(i,k) - qeso(i,k)) + qcond(i) = shevf * evef * (q1(i,k) - qeso(i,k)) & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) dp = 1000. * del(i,k) factor = dp / grav diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index be54675b0..eb2b7ad1c 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -138,7 +138,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & integer i,is,k,n,ndt,km1,kmpbl,kmscu,ntrac1,idtend integer kps,kbx,kmx integer lcld(im),kcld(im),krad(im),mrad(im) - integer kx1(im), kpblx(im) + integer kx1(im), kb1(im), kpblx(im) ! real(kind=kind_phys) tke(im,km), tkeh(im,km-1) ! @@ -198,6 +198,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & & q_diff(im,0:km-1,ntrac-1) real(kind=kind_phys) rrkp, phkp real(kind=kind_phys) tsumn(im), tsump(im), rtnp(im) + real(kind=kind_phys) sfcpbl(im) ! logical pblflg(im), sfcflg(im), flg(im) logical scuflg(im), pcnvflg(im) @@ -233,6 +234,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & & zlup, zldn, bsum, cs0, & tem, tem1, tem2, tem3, & ptem, ptem0, ptem1, ptem2 +! + real(kind=kind_phys) slfac ! real(kind=kind_phys) ck0, ck1, ch0, ch1, ce0, rchck ! @@ -242,7 +245,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & !! parameter(wfac=7.0,cfac=4.5) parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) - parameter(vk=0.4,rimin=-100.) + parameter(vk=0.4,rimin=-100.,slfac=0.1) parameter(rbcr=0.25,zolcru=-0.02,tdzmin=1.e-3) parameter(rlmn=30.,rlmn0=5.,rlmn1=5.,rlmn2=10.) parameter(prmin=0.25,prmax=4.0) @@ -573,7 +576,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & enddo enddo ! -! Find pbl height based on bulk richardson number (mrf pbl scheme) +! Find first quess pbl height based on bulk richardson number (mrf pbl scheme) ! and also for diagnostic purpose ! do i=1,im @@ -623,6 +626,73 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & if(kpbl(i) <= 1) pblflg(i)=.false. enddo ! +! update thermal at a level of slfac*hpbl for unstable pbl +! + do i=1,im + sfcpbl(i) = slfac * hpbl(i) + kb1(i) = 1 + flg(i) = .false. + if(pblflg(i)) then + flg(i) = .true. + endif + enddo + do k = 2, kmpbl + do i=1,im + if (flg(i) .and. zl(i,k) <= sfcpbl(i)) then + kb1(i) = k + else + flg(i) = .false. + endif + enddo + enddo + do i=1,im + if(pblflg(i)) kb1(i)=min(kb1(i),kpbl(i)) + enddo +! +! re-compute pbl height with the updated thermal +! + do i=1,im + flg(i) = .true. + if(pblflg(i) .and. kb1(i) > 1) then + flg(i) = .false. + rbup(i) = rbsoil(i) +! thermal(i) = thvx(i,kb1(i)) + thermal(i) = thlvx(i,kb1(i)) + kpblx(i) = kb1(i) + hpblx(i) = zl(i,kb1(i)) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i) .and. k > kb1(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) +! rbup(i) = (thvx(i,k)-thermal(i))* +! & (g*zl(i,k)/thvx(i,1))/spdk2 + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + kpblx(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(pblflg(i) .and. kb1(i) > 1) then + k = kpblx(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpblx(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpblx(i) < zi(i,kpblx(i))) kpblx(i)=kpblx(i)-1 + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + endif + enddo +! !> ## Compute Monin-Obukhov similarity parameters !! - Calculate the Monin-Obukhov nondimensional stability paramter, commonly !! referred to as \f$\zeta\f$ using the following equation from Businger et al.(1971) \cite businger_et_al_1971 @@ -716,7 +786,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & enddo do k = 2, kmpbl do i = 1, im - if(.not.flg(i)) then + if(.not.flg(i) .and. k > kb1(i)) then rbdn(i) = rbup(i) spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) rbup(i) = (thlvx(i,k)-thermal(i))* From a6e960def5b06abc15b5796a6e5ec4aef9368350 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 15 Mar 2022 16:09:56 +0000 Subject: [PATCH 118/217] Revert change from previous commits (sampling of different cloud types). --- physics/rrtmgp_lw_cloud_sampling.F90 | 73 ---------------------------- physics/rrtmgp_lw_rte.F90 | 20 ++++---- physics/rrtmgp_lw_rte.meta | 8 +-- physics/rrtmgp_sw_cloud_optics.F90 | 3 ++ physics/rrtmgp_sw_cloud_sampling.F90 | 66 ------------------------- physics/rrtmgp_sw_rte.F90 | 16 +++--- physics/rrtmgp_sw_rte.meta | 8 +-- 7 files changed, 29 insertions(+), 165 deletions(-) diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 index cf7c0535e..cb11607dc 100644 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ b/physics/rrtmgp_lw_cloud_sampling.F90 @@ -155,79 +155,6 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iov lw_optical_props_cloudsByBand, & lw_optical_props_clouds)) - ! #################################################################################### - ! Convective cloud ... - ! (Use same RNGs as was used by the clouds.) - ! #################################################################################### - if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then - lw_optical_props_cnvclouds%band2gpt = lw_gas_props%get_band_lims_gpoint() - lw_optical_props_cnvclouds%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_cnvclouds%gpt2band(lw_optical_props_cnvclouds%band2gpt(1,iBand):& - lw_optical_props_cnvclouds%band2gpt(2,iBand)) = iBand - end do - - ! Convective cloud overlap - ! Maximum-random, random or maximum. - if (iovr_convcld == iovr_maxrand .or. iovr_convcld == iovr_rand .or. iovr_convcld == iovr_max) then - call sampled_mask(rng3D, cld_cnv_frac, maskMCICA) - endif - ! Exponential decorrelation length overlap - if (iovr_convcld == iovr_dcorr) then - call sampled_mask(rng3D, cld_cnv_frac, maskMCICA, & - overlap_param = cnv_cloud_overlap_param(:,1:nLev-1), & - randoms2 = rng3D2) - endif - ! Exponential or Exponential-random - if (iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then - call sampled_mask(rng3D, cld_cnv_frac, maskMCICA, & - overlap_param = cnv_cloud_overlap_param(:,1:nLev-1)) - endif - - ! - ! Sampling. Map band optical depth to each g-point using McICA - ! - call check_error_msg('rrtmgp_lw_cnvcloud_sampling_run_draw_samples',& - draw_samples(maskMCICA, .true., & - lw_optical_props_cnvcloudsByBand, & - lw_optical_props_cnvclouds)) - endif - - ! #################################################################################### - ! Next sample the precipitation... - ! (Use same RNGs as was used by the clouds.) - ! #################################################################################### - lw_optical_props_precip%band2gpt = lw_gas_props%get_band_lims_gpoint() - lw_optical_props_precip%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_precip%gpt2band(lw_optical_props_precip%band2gpt(1,iBand):lw_optical_props_precip%band2gpt(2,iBand)) = iBand - end do - - ! Precipitation overlap. - ! Maximum-random, random or maximum. - if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, precip_frac, maskMCICA) - endif - ! Exponential decorrelation length overlap - if (iovr == iovr_dcorr) then - call sampled_mask(rng3D, precip_frac, maskMCICA, & - overlap_param = precip_overlap_param(:,1:nLev-1), & - randoms2 = rng3D2) - endif - ! Exponential or Exponential-random - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, precip_frac, maskMCICA, & - overlap_param = precip_overlap_param(:,1:nLev-1)) - endif - - ! - ! Sampling. Map band optical depth to each g-point using McICA - ! - call check_error_msg('rrtmgp_lw_precip_sampling_run_draw_samples',& - draw_samples(maskMCICA, .true., & - lw_optical_props_precipByBand, & - lw_optical_props_precip)) - end subroutine rrtmgp_lw_cloud_sampling_run ! ######################################################################################### diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index 131b7d6e5..a141a4e08 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -26,12 +26,12 @@ end subroutine rrtmgp_lw_rte_init !! \htmlinclude rrtmgp_lw_rte_run.html !! subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & - nLev, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, & - sfc_emiss_byband, sources, lw_optical_props_clrsky, lw_optical_props_clouds, & - lw_optical_props_precip, lw_optical_props_cnvclouds, & - lw_optical_props_MYNNcloudsByBand, lw_optical_props_aerosol, nGauss_angles, & - fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac,& - fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg) + nLev, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, sfc_emiss_byband, sources, & + lw_optical_props_clrsky, lw_optical_props_clouds, lw_optical_props_precipByBand, & + lw_optical_props_cnvcloudsByBand, lw_optical_props_MYNNcloudsByBand, & + lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, fluxlwDOWN_allsky, & + fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwUP_radtime, & + fluxlwDOWN_radtime, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -55,8 +55,8 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, lw_optical_props_clrsky ! RRTMGP DDT: longwave clear-sky optical properties type(ty_optical_props_2str),intent(inout) :: & lw_optical_props_clouds, & ! RRTMGP DDT: longwave cloud optical properties - lw_optical_props_precip, & ! RRTMGP DDT: longwave precipitation optical properties - lw_optical_props_cnvclouds, & ! RRTMGP DDT: longwave convective cloud optical properties + lw_optical_props_precipByBand, & ! RRTMGP DDT: longwave precipitation optical properties + lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: longwave convective cloud optical properties lw_optical_props_MYNNcloudsByBand ! RRTMGP DDT: longwave MYNN-EDMF PBL cloud optical properties ! Outputs real(kind_phys), dimension(:,:), intent(inout) :: & @@ -132,7 +132,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, ! Include convective cloud? if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_cnvclouds%increment(lw_optical_props_clrsky)) + call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_clrsky)) endif ! Include MYNN-EDMF PBL clouds? @@ -141,7 +141,7 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, endif ! Add in precipitation - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_precip%increment(lw_optical_props_clouds)) + call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_precipByBand%increment(lw_optical_props_clouds)) ! Include LW cloud-scattering? if (doGP_lwscat) then diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 39dba368b..0ad0754b5 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -100,15 +100,15 @@ dimensions = () type = ty_optical_props_2str intent = inout -[lw_optical_props_precip] - standard_name = longwave_optical_properties_for_precipitation +[lw_optical_props_precipByBand] + standard_name = longwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () type = ty_optical_props_2str intent = inout -[lw_optical_props_cnvclouds] - standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere +[lw_optical_props_cnvcloudsByBand] + standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index bac62fb13..fd648de02 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -516,6 +516,9 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw ! iv) Cloud precipitation optics: rain and snow(+groupel) call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_precipByBand',& sw_optical_props_precipByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys + sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys + sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys do iDay=1,nDay do iLay=1,nLev diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 index 1c1da46db..c4a5de4c8 100644 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -157,72 +157,6 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, draw_samples(maskMCICA, .true., & sw_optical_props_cloudsByBand, & sw_optical_props_clouds)) - - ! ################################################################################# - ! Convective cloud... - ! (Use same RNGs as was used by the clouds.) - ! ################################################################################# - if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then - - ! Allocate space RRTMGP DDTs [nday,nLev,nGpt] - call check_error_msg('rrtmgp_sw_cnvcloud_sampling_run', & - sw_optical_props_cnvclouds%alloc_2str( nday, nLev, sw_gas_props)) - - ! Maximum-random, random or maximum overlap - if (iovr_convcld == iovr_maxrand .or. iovr_convcld == iovr_max .or. iovr_convcld == iovr_rand) then - call sampled_mask(rng3D, cld_cnv_frac(idxday(1:nDay),:), maskMCICA) - endif - ! Exponential decorrelation length overlap - if (iovr_convcld == iovr_dcorr) then - call sampled_mask(rng3D, cld_cnv_frac(idxday(1:nDay),:), maskMCICA, & - overlap_param = cnv_cloud_overlap_param(idxday(1:nDay),1:nLev-1),& - randoms2 = rng3D2) - endif - if (iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then - call sampled_mask(rng3D, cld_cnv_frac(idxday(1:nDay),:), maskMCICA, & - overlap_param = cnv_cloud_overlap_param(idxday(1:nDay),1:nLev-1)) - endif - - ! - ! Sampling. Map band optical depth to each g-point using McICA - ! - call check_error_msg('rrtmgp_sw_cnvcloud_sampling_run_draw_samples', & - draw_samples(maskMCICA, .true., & - sw_optical_props_cnvcloudsByBand, & - sw_optical_props_cnvclouds)) - endif - ! ################################################################################# - ! Preciptitation... - ! (Use same RNGs as was used by the clouds.) - ! ################################################################################# - - ! Allocate space RRTMGP DDTs [nday,nLev,nGpt] - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sw_optical_props_precip%alloc_2str( nday, nLev, sw_gas_props)) - - ! Precipitation overlap - ! Maximum-random, random or maximum precipitation overlap - if (iovr == iovr_maxrand .or. iovr == iovr_max .or. iovr == iovr_rand) then - call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), maskMCICA) - endif - ! Exponential decorrelation length overlap - if (iovr == iovr_dcorr) then - call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), maskMCICA, & - overlap_param = precip_overlap_param(idxday(1:nDay),1:nLev-1),& - randoms2 = rng3D2) - endif - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), maskMCICA, & - overlap_param = precip_overlap_param(idxday(1:nDay),1:nLev-1)) - endif - - ! - ! Sampling. Map band optical depth to each g-point using McICA - ! - call check_error_msg('rrtmgp_sw_precip_sampling_run_draw_samples', & - draw_samples(maskMCICA, .true., & - sw_optical_props_precipByBand, & - sw_optical_props_precip)) endif end subroutine rrtmgp_sw_cloud_sampling_run diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index 4240e3f93..76f359980 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -25,10 +25,10 @@ end subroutine rrtmgp_sw_rte_init !! \htmlinclude rrtmgp_sw_rte.html !! subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay,& - t_lay, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, iSFC, & - sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, & - sw_optical_props_clrsky, sw_optical_props_clouds, sw_optical_props_precip, & - sw_optical_props_cnvclouds, sw_optical_props_MYNNcloudsByBand, & + t_lay, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, iSFC, sfc_alb_nir_dir, sfc_alb_nir_dif,& + sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clrsky, & + sw_optical_props_clouds, sw_optical_props_precipByBand, & + sw_optical_props_cnvcloudsByBand, sw_optical_props_MYNNcloudsByBand, & sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, & fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) @@ -55,9 +55,9 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties type(ty_optical_props_2str),intent(in) :: & sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud optical properties - sw_optical_props_cnvclouds, & ! RRTMGP DDT: shortwave convecive cloud optical properties + sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: shortwave convecive cloud optical properties sw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: shortwave MYNN-EDMF PBL cloud optical properties - sw_optical_props_precip, & ! RRTMGP DDT: shortwave precipitation optical properties + sw_optical_props_precipByBand, & ! RRTMGP DDT: shortwave precipitation optical properties sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol optical properties real(kind_phys), dimension(:,:), intent(in) :: & sfc_alb_nir_dir, & ! Surface albedo (direct) @@ -155,7 +155,7 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz ! Include convective cloud? if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_cnvclouds%increment(sw_optical_props_clrsky)) + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_clrsky)) endif ! Include MYNN-EDMF PBL cloud? @@ -164,7 +164,7 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz endif ! All-sky fluxes (clear-sky + clouds + precipitation) - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_precip%increment(sw_optical_props_clrsky)) + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_precipByBand%increment(sw_optical_props_clrsky)) call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clouds%increment(sw_optical_props_clrsky)) ! Delta-scale optical properties diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index 99a0b70e2..d89d0d966 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -116,15 +116,15 @@ dimensions = () type = ty_optical_props_2str intent = in -[sw_optical_props_precip] - standard_name = shortwave_optical_properties_for_precipitation +[sw_optical_props_precipByBand] + standard_name = shortwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () type = ty_optical_props_2str intent = in -[sw_optical_props_cnvclouds] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere +[sw_optical_props_cnvcloudsByBand] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () From c722905e5240250ac7986624af0688f12737d8fb Mon Sep 17 00:00:00 2001 From: helin wei Date: Wed, 16 Mar 2022 03:20:38 +0000 Subject: [PATCH 119/217] replace shdfac by fveg for zvfun --- physics/module_sf_noahmplsm.f90 | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 360536ec3..ef022b4ee 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4032,7 +4032,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp, & !in + zpd ,snowh ,fveg ,garea1 ,.true. ,vaie ,vegtyp, & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out @@ -4492,7 +4492,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in + zpd ,snowh,fveg ,garea1 ,.false. ,0.0,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out @@ -5161,14 +5161,17 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur fv = ustarx laimax = maxval(parameters%laim) saimax = maxval(parameters%saim) - - if(laimax+saimax .gt. 0) then + if(dveg.eq.4 .or. dveg.eq.5) then + if(laimax+saimax .gt. 0 .and. fveg .gt. 0) then slaifrac=vaie/(laimax+saimax) slaifrac=min(slaifrac,1.) slaifrac=fveg*slaifrac else slaifrac=0.1_kind_phys endif + else + slaifrac=fveg + endif ! fv = ur*vkc/log((zlvl-zpd)/z0m) From 4284846e2110f9c6e6781de2c002ae35964f03a1 Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Fri, 18 Mar 2022 14:45:38 +0000 Subject: [PATCH 120/217] modify the eddy diffusivity for heat at the top of the canopy --- physics/module_sf_noahmplsm.f90 | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index ef022b4ee..6e59407bb 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -3828,6 +3828,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: fm !momentum stability correction, weighted by prior iters real (kind=kind_phys) :: fh !sen heat stability correction, weighted by prior iters real (kind=kind_phys) :: fhg !sen heat stability correction, ground + real (kind=kind_phys) :: fhgh !sen heat stability correction, canopy real (kind=kind_phys) :: hcan !canopy height (m) [note: hcan >= z0mg] real (kind=kind_phys) :: a !temporary calculation @@ -4048,7 +4049,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & call ragrb(parameters,iter ,vaie ,rhoair ,hg ,tah , & !in zpd ,z0mg ,z0hg ,hcan ,uc , & !in z0h ,fv ,cwp ,vegtyp ,mpe , & !in - tv ,mozg ,fhg ,iloc ,jloc , & !inout + tv ,mozg ,fhg ,fhgh ,iloc ,jloc , & !inout ramg ,rahg ,rawg ,rb ) !out ! es and d(es)/dt evaluated at tv @@ -4604,7 +4605,7 @@ end subroutine bare_flux subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in zpd ,z0mg ,z0hg ,hcan ,uc , & !in z0h ,fv ,cwp ,vegtyp ,mpe , & !in - tv ,mozg ,fhg ,iloc ,jloc , & !inout + tv ,mozg ,fhg ,fhgh ,iloc ,jloc , & !inout ramg ,rahg ,rawg ,rb ) !out ! -------------------------------------------------------------------------------------------------- ! compute under-canopy aerodynamic resistance rag and leaf boundary layer @@ -4638,6 +4639,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in real (kind=kind_phys), intent(inout) :: mozg !monin-obukhov stability parameter real (kind=kind_phys), intent(inout) :: fhg !stability correction + real (kind=kind_phys), intent(inout) :: fhgh !stability correction, canopy ! outputs real (kind=kind_phys) :: ramg !aerodynamic resistance for momentum (s/m) @@ -4652,29 +4654,36 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in real (kind=kind_phys) :: tmprah2 !temporary calculation for aerodynamic resistances real (kind=kind_phys) :: tmprb !temporary calculation for rb real (kind=kind_phys) :: molg,fhgnew,cwpc + real (kind=kind_phys) :: mozgh, fhgnewh ! -------------------------------------------------------------------------------------------------- ! stability correction to below canopy resistance mozg = 0. molg = 0. + mozgh = 0. if(iter > 1) then tmp1 = vkc * (grav/tah) * hg/(rhoair*cpair) if (abs(tmp1) .le. mpe) tmp1 = mpe molg = -1. * fv**3 / tmp1 mozg = min( (zpd-z0mg)/molg, 1.) + mozgh = min( (hcan - zpd)/molg, 1.) end if if (mozg < 0.) then fhgnew = (1. - 15.*mozg)**(-0.25) + fhgnewh = 0.74 * (1. - 9.*mozg)**(-0.5) ! PHIh else fhgnew = 1.+ 4.7*mozg + fhgnewh = 0.74 + 4.7*mozgh ! PHIh endif if (iter == 1) then fhg = fhgnew + fhgh = fhgnewh else fhg = 0.5 * (fhg+fhgnew) + fhgh = 0.5 * (fhgh+fhgnewh) endif cwpc = (cwp * vai * hcan * fhg)**0.5 @@ -4686,7 +4695,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - kh = max ( vkc*fv*(hcan-zpd), mpe ) + kh = max ( vkc*fv*(hcan-zpd)/fhgh, mpe ) ramg = 0. rahg = tmprah2 / kh rawg = rahg From 4aa59df23cc99a6c523fa37785c399df946ae719 Mon Sep 17 00:00:00 2001 From: rongqian yang Date: Fri, 18 Mar 2022 19:10:49 +0000 Subject: [PATCH 121/217] Noah MP driver and meta changes for MYNN --- physics/sfc_noahmp_drv.F90 | 106 ++++++++++++++++++++++++++++++++++-- physics/sfc_noahmp_drv.meta | 53 ++++++++++++++++++ 2 files changed, 154 insertions(+), 5 deletions(-) diff --git a/physics/sfc_noahmp_drv.F90 b/physics/sfc_noahmp_drv.F90 index 0ebcbd615..a16534364 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/sfc_noahmp_drv.F90 @@ -11,8 +11,12 @@ !> This module contains the CCPP-compliant NoahMP land surface model driver. module noahmpdrv + use module_sf_noahmplsm + implicit none + integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS + private public :: noahmpdrv_init, noahmpdrv_run, noahmpdrv_finalize @@ -27,6 +31,7 @@ module noahmpdrv !! subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & nlunit, pores, resid, & + do_mynnsfclay,do_mynnedmf, & errmsg, errflg) use machine, only: kind_phys @@ -40,6 +45,10 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & real (kind=kind_phys), dimension(:), intent(out) :: pores, resid + logical, intent(in) :: do_mynnsfclay + logical, intent(in) :: do_mynnedmf + + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -68,9 +77,31 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & return end if + if (.not. do_mynnsfclay .and. do_mynnedmf) then + errmsg = 'Problem : do_mynnsfclay = .false.' // & + 'but mynnpbl is .true.. Exiting ...' + errflg = 1 + return + end if + + if ( do_mynnsfclay .and. .not. do_mynnedmf) then + errmsg = 'Problem : do_mynnsfclay = .true.' // & + 'but mynnpbl is .false.. Exiting ...' + errflg = 1 + return + end if + + !--- initialize soil vegetation call set_soilveg(me, isot, ivegsrc, nlunit) + + ! initialize psih and psim + + if ( do_mynnsfclay ) then + call psi_init(psi_opt,errmsg,errflg) + endif + pores (:) = maxsmc (:) resid (:) = drysmc (:) @@ -107,7 +138,7 @@ subroutine noahmpdrv_run & ! --- inputs: ( im, km, lsnowl, itime, ps, u1, v1, t1, q1, soiltyp, & vegtype, sigmaf, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & - prsl1, prslk1, prslki, prsik1, zf, dry, wind, slopetyp, & + prsl1, prslk1, prslki, prsik1, zf,pblh, dry, wind, slopetyp, & shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & @@ -120,6 +151,7 @@ subroutine noahmpdrv_run & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & canopy, trans, tsurf, zorl, & rb1, fm1, fh1, ustar1, stress1, fm101, fh21, & + rmol1,flhc1,flqc1,do_mynnsfclay, & ! --- Noah MP specific @@ -140,7 +172,7 @@ subroutine noahmpdrv_run & use funcphys, only : fpvs use sfc_diff, only : stability - use module_sf_noahmplsm +! use module_sf_noahmplsm use module_sf_noahmp_glacier use noahmp_tables, only : isice_table, co2_table, o2_table, & isurban_table, smcref_table, smcdry_table, & @@ -160,6 +192,8 @@ subroutine noahmpdrv_run & integer, parameter :: nsoil = 4 ! hardwired to Noah integer, parameter :: nsnow = 3 ! max. snow layers + integer, parameter :: iz0tlnd = 0 ! z0t treatment option + real(kind=kind_phys), save :: zsoil(nsoil) data zsoil / -0.1, -0.4, -1.0, -2.0 / @@ -193,6 +227,15 @@ subroutine noahmpdrv_run & real(kind=kind_phys), dimension(:) , intent(in) :: prsik1 ! Exner function at the ground surfac real(kind=kind_phys), dimension(:) , intent(in) :: zf ! height of bottom layer [m] + + logical , intent(in) :: do_mynnsfclay !flag for MYNN sfc layer scheme + + real(kind=kind_phys), dimension(:) , intent(in) :: pblh ! height of pbl + real(kind=kind_phys), dimension(:) , intent(inout) :: rmol1 ! + real(kind=kind_phys), dimension(:) , intent(inout) :: flhc1 ! + real(kind=kind_phys), dimension(:) , intent(inout) :: flqc1 ! + + logical , dimension(:) , intent(in) :: dry ! = T if a point with any land real(kind=kind_phys), dimension(:) , intent(in) :: wind ! wind speed [m/s] integer , dimension(:) , intent(in) :: slopetyp ! surface slope classification @@ -505,6 +548,16 @@ subroutine noahmpdrv_run & real (kind=kind_phys) :: prsik1x ! in exner function real (kind=kind_phys) :: prslk1x ! in exner function + real (kind=kind_phys) :: ch2 + real (kind=kind_phys) :: cq2 + real (kind=kind_phys) :: qfx + real (kind=kind_phys) :: wspd1 ! wind speed with all components + real (kind=kind_phys) :: pblhx ! height of pbl + + real (kind=kind_phys) :: rah_total ! + real (kind=kind_phys) :: cah_total ! + + ! ! --- local variable ! @@ -594,6 +647,8 @@ subroutine noahmpdrv_run & vwind_forcing = v1(i) area_grid = garea(i) + pblhx = pblh(i) + prslkix = prslki(i) prsik1x = prsik1(i) prslk1x = prslk1(i) @@ -725,7 +780,8 @@ subroutine noahmpdrv_run & spec_humidity_forcing,sw_radiation_forcing ,precipitation_forcing,radiation_lw_forcing , & temperature_soil_bot ,forcing_height ,snow_ice_frac_old ,zsoil , & thsfc_loc ,prslkix ,prsik1x ,prslk1x , & - vegetation_frac ,area_grid , & + air_pressure_surface ,pblhx ,iz0tlnd ,itime , & + vegetation_frac ,area_grid ,psi_opt , & snowfall ,snow_water_equiv_old ,snow_albedo_old , & cm_noahmp ,ch_noahmp ,snow_levels ,snow_water_equiv , & soil_moisture_vol ,interface_depth ,snow_depth ,snow_level_ice , & @@ -804,6 +860,8 @@ subroutine noahmpdrv_run & spec_humidity_forcing ,area_grid ,cloud_water_forcing , & sw_radiation_forcing ,radiation_lw_forcing ,thsfc_loc , & prslkix ,prsik1x ,prslk1x , & + pblhx ,iz0tlnd ,itime , & + psi_opt , & precip_convective , & precip_non_convective ,precip_sh_convective ,precip_snow , & precip_graupel ,precip_hail ,temperature_soil_bot , & @@ -923,7 +981,7 @@ subroutine noahmpdrv_run & snowc (i) = snow_cover_fraction sncovr1 (i) = snow_cover_fraction - qsurf (i) = spec_humidity_surface +! qsurf (i) = spec_humidity_surface tsurf (i) = tskin(i) tvxy (i) = temperature_leaf @@ -986,11 +1044,49 @@ subroutine noahmpdrv_run & zvfun(i) = sqrt(tem1 * tem2) gdx=sqrt(garea(i)) + if ( .not. do_mynnsfclay) then !GFS sfcdiff + call stability & (zf(i), zvfun(i), gdx, virtual_temperature, vptemp,wind(i), z0_total, z0h_total, & tvs1, con_g, thsfc_loc, & rb1(i), fm1(i), fh1(i), fm101(i), fh21(i), cm(i), ch(i), stress1(i), ustar1(i)) + rmol1(i) = undefined !not used in GFS sfcdif -> to satsify output + flhc1(i) = undefined + flqc1(i) = undefined + + rah_total = max(1.0,1.0/( ch(i)*wind(i)) ) + cah_total = density * con_cp /rah_total +! tskin(i) = sensible_heat_total/cah_total + temperature_forcing ! test to use combined ch and SH to backout Ts + + ch(i) = ch_vegetated * vegetation_frac + ch_bare_ground*(1.0-vegetation_frac) + + else ! MYNN - note the GFS option is the same as sfcdif3; so removed. + + qfx = evap(i) / con_hvap ! use flux from output + + call sfcdif4(i_location ,j_location ,uwind_forcing ,vwind_forcing , & + temperature_forcing, air_pressure_forcing ,air_pressure_surface , & + pblhx,gdx,z0_total,itime,snwdph(i),0,psi_opt,surface_temperature, & + spec_humidity_forcing,forcing_height,iz0tlnd,spec_humidity_surface,& + sensible_heat_total,qfx,cm(i),ch(i),ch2,cq2,rmol1(i),ustar1(i), & + rb1(i),fm1(i),fh1(i),stress1(i),fm101(i),fh21(i),wspd1,flhc1(i), & + flqc1(i) ) + + ch(i)=ch(i)/wspd1 + cm(i)=cm(i)/wspd1 + + ch(i) = ch_vegetated * vegetation_frac + ch_bare_ground*(1.0-vegetation_frac) + + rah_total = max(1.0,1.0/( ch(i)*wind(i)) ) + cah_total = density * con_cp /rah_total + +! tskin(i) = sensible_heat_total/cah_total + temperature_forcing ! + + endif + + + cmxy(i) = cm(i) chxy(i) = ch(i) @@ -998,7 +1094,7 @@ subroutine noahmpdrv_run & cmm (i) = cmxy(i) * wind(i) snwdph (i) = snow_depth * 1000.0 ! convert from m to mm; wait after the stability call -! qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) + qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) ! ! --- change units for output diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 1246fa1b0..9ad9092ec 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -65,6 +65,20 @@ type = real intent = out kind = kind_phys +[do_mynnsfclay] + standard_name = flag_for_mellor_yamada_nakanishi_niino_surface_layer_scheme + long_name = flag to activate MYNN surface layer + units = flag + dimensions = () + type = logical + 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 [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -271,6 +285,14 @@ type = real kind = kind_phys intent = in +[pblh] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [dry] standard_name = flag_nonzero_land_surface_fraction long_name = flag indicating presence of some land surface area fraction @@ -741,6 +763,37 @@ type = real kind = kind_phys intent = inout +[rmol1] + 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 = inout +[flhc1] + standard_name = surface_exchange_coefficient_for_heat + long_name = surface exchange coefficient for heat + units = W m-2 K-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[flqc1] + standard_name = surface_exchange_coefficient_for_moisture + long_name = surface exchange coefficient for moisture + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[do_mynnsfclay] + standard_name = flag_for_mellor_yamada_nakanishi_niino_surface_layer_scheme + long_name = flag to activate MYNN surface layer + units = flag + dimensions = () + type = logical + intent = in [snowxy] standard_name = number_of_snow_layers long_name = number of snow layers From c58e8492ddd6ee76b85a66ddbddd10d7dc3db76c Mon Sep 17 00:00:00 2001 From: rongqian yang Date: Fri, 18 Mar 2022 19:12:25 +0000 Subject: [PATCH 122/217] Noah MP glacier changes for MYNN --- physics/module_sf_noahmp_glacier.f90 | 101 +++++++++++++++++++++++++-- 1 file changed, 97 insertions(+), 4 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index c4c03aaf8..997166744 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -7,6 +7,7 @@ module noahmp_glacier_globals use machine , only : kind_phys use sfc_diff, only : stability + use module_sf_noahmplsm, only : sfcdif4 implicit none @@ -122,7 +123,9 @@ subroutine noahmp_glacier (& iloc ,jloc ,cosz ,nsnow ,nsoil ,dt , & ! in : time/space/model-related sfctmp ,sfcprs ,uu ,vv ,q2 ,soldn , & ! in : forcing prcp ,lwdn ,tbot ,zlvl ,ficeold ,zsoil , & ! in : forcing - thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & ! in : + thsfc_loc ,prslkix ,prsik1x ,prslk1x , & + psfc ,pblhx ,iz0tlnd ,itime , & + sigmaf1 ,garea1 ,psi_opt , & ! in : qsnow ,sneqvo ,albold ,cm ,ch ,isnow , & ! in/out : sneqv ,smc ,zsnso ,snowh ,snice ,snliq , & ! in/out : tg ,stc ,sh2o ,tauss ,qsfc , & ! in/out : @@ -149,6 +152,8 @@ subroutine noahmp_glacier (& real (kind=kind_phys) , intent(in) :: cosz !< cosine solar zenith angle [0-1] integer , intent(in) :: nsnow !< maximum no. of snow layers integer , intent(in) :: nsoil !< no. of soil layers + integer , intent(in) :: psi_opt + real (kind=kind_phys) , intent(in) :: dt !< time step [sec] real (kind=kind_phys) , intent(in) :: sfctmp !< surface air temperature [k] real (kind=kind_phys) , intent(in) :: sfcprs !< pressure (pa) @@ -166,6 +171,12 @@ subroutine noahmp_glacier (& real (kind=kind_phys) , intent(in) :: prslkix !< pressure (pa) real (kind=kind_phys) , intent(in) :: prsik1x !< pressure (pa) real (kind=kind_phys) , intent(in) :: prslk1x !< pressure (pa) + + real (kind=kind_phys) , intent(in) :: psfc ! surface pressure + real (kind=kind_phys) , intent(in) :: pblhx ! pbl height + integer , intent(in) :: iz0tlnd ! + integer , intent(in) :: itime !< timestep + real (kind=kind_phys) , intent(in) :: sigmaf1 !< areal fractional cover of green vegetation real (kind=kind_phys) , intent(in) :: garea1 !< area of the grid cell @@ -274,6 +285,7 @@ subroutine noahmp_glacier (& vv ,solad ,solai ,cosz ,zlvl , & !in tbot ,zbot ,zsnso ,dzsnso ,sigmaf1 ,garea1 , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & !in + psfc ,pblhx ,iz0tlnd ,itime ,psi_opt , & tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout #ifdef CCPP @@ -405,6 +417,7 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair vv ,solad ,solai ,cosz ,zref , & !in tbot ,zbot ,zsnso ,dzsnso ,sigmaf1 ,garea1 , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & !in + psfc ,pblhx ,iz0tlnd ,itime ,psi_opt , & tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout #ifdef CCPP @@ -427,6 +440,8 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair ! inputs integer , intent(in) :: nsnow !< maximum no. of snow layers integer , intent(in) :: nsoil !< number of soil layers + integer , intent(in) :: psi_opt + integer , intent(in) :: isnow !< actual no. of snow layers real (kind=kind_phys) , intent(in) :: dt !< time step [sec] real (kind=kind_phys) , intent(in) :: qsnow !< snowfall on the ground (mm/s) @@ -451,6 +466,12 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair real (kind=kind_phys) , intent(in) :: prslkix ! in exner function real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function + + real (kind=kind_phys) , intent(in) :: pblhx !< PBL height (m) + real (kind=kind_phys) , intent(in) :: psfc !< surface pressure + integer , intent(in) :: iz0tlnd !< z0t option + integer , intent(in) :: itime !< integration time + real (kind=kind_phys) , intent(in) :: sigmaf1 !< areal fractional cover of green vegetation real (kind=kind_phys) , intent(in) :: garea1 !< area of the grid cell @@ -561,7 +582,9 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in - thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & !in + thsfc_loc ,prslkix ,prsik1x ,prslk1x , & + psfc ,pblhx ,iz0tlnd ,itime ,uu ,vv , & + sigmaf1 ,garea1 ,psi_opt , & !in #ifdef CCPP cm ,ch ,tg ,qsfc ,errmsg ,errflg , & !inout #else @@ -997,7 +1020,9 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in - thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & !in + thsfc_loc ,prslkix ,prsik1x ,prslk1x , & + psfc ,pblhx ,iz0tlnd ,itime ,uu ,vv , & + sigmaf1 ,garea1 ,psi_opt , & !in #ifdef CCPP cm ,ch ,tgb ,qsfc ,errmsg ,errflg , & !inout #else @@ -1020,6 +1045,8 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! input integer, intent(in) :: nsnow !< maximum no. of snow layers integer, intent(in) :: nsoil !< number of soil layers + integer, intent(in) :: psi_opt + real (kind=kind_phys), intent(in) :: emg !< ground emissivity integer, intent(in) :: isnow !< actual no. of snow layers real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df !< thermal conductivity of snow/soil (w/m/k) @@ -1048,6 +1075,14 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso real (kind=kind_phys), intent(in) :: prslkix ! in exner function real (kind=kind_phys), intent(in) :: prsik1x ! in exner function real (kind=kind_phys), intent(in) :: prslk1x ! in exner function + + real (kind=kind_phys) , intent(in) :: pblhx !< + real (kind=kind_phys) , intent(in) :: psfc !< + integer , intent(in) :: iz0tlnd !< + integer , intent(in) :: itime !< integration time + real (kind=kind_phys) , intent(in) :: uu !< + real (kind=kind_phys) , intent(in) :: vv !< + real (kind=kind_phys), intent(in) :: sigmaf1 ! real (kind=kind_phys), intent(in) :: garea1 ! @@ -1095,11 +1130,19 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso integer :: iter !< iteration index real (kind=kind_phys) :: z0h !< roughness length, sensible heat, ground (m) + real (kind=kind_phys) :: qfx + real (kind=kind_phys) :: cq2 !< surface exchange at 2m + + real(kind=kind_phys) :: rb1i ! bulk richardson # real(kind=kind_phys) :: fm10i ! fm10 over land ice real(kind=kind_phys) :: stress1i! wind stress m2 S-2 + real(kind=kind_phys) :: wspd1i + real(kind=kind_phys) :: flhc1i + real(kind=kind_phys) :: flqc1i + real(kind=kind_phys) :: tv1i ! virtual potential temp @ ref level real(kind=kind_phys) :: thv1i ! virtual potential temp @ ref level @@ -1149,6 +1192,10 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso h = 0. + fh2 = 0. + qfx = 0. + + ! the following only applies to opt_sfc =3, opt_sfc = 1 still done its old way snwd = snowh*1000.0 @@ -1194,8 +1241,10 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso tem2 = max(sigmaf1, 0.1_kind_phys) zvfun1= sqrt(tem1 * tem2) gdx=sqrt(garea1) - if(opt_sfc == 1 .or. opt_sfc == 2) then !Add option for sfc scheme,use '1' for both '1'/'2' + + if(opt_sfc == 1 .or. opt_sfc == 2 .or. opt_sfc == 4) then !Add option for sfc scheme,use '1' for both '1'/'2' loop3: do iter = 1, niterb ! begin stability iteration + if(opt_sfc == 1 .or. opt_sfc == 2) then ! for now, only allow sfcdif1 until others can be fixed @@ -1211,8 +1260,45 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso #ifdef CCPP if (errflg /= 0) return #endif + endif + + if(opt_sfc == 4) then + + call sfcdif4(1 ,1 ,uu ,vv ,sfctmp , & !allow location for use in the driver + sfcprs ,psfc ,pblhx ,gdx ,z0m , & + itime ,snwd ,1 ,psi_opt, & + tgb ,qair ,zlvl ,iz0tlnd,qsfc , & ! use zlvli? + h ,qfx ,cm ,ch ,ch2 , & ! ch2 = cq2 most of times + cq2 ,moz ,fv ,rb1i, fm, fh, & + stress1i,fm10i ,fh2 , wspd1i ,flhc1i ,flqc1i) ! some are for use in the driver call + + + ! Undo the multiplication by windspeed that SFCDIF4 + ! applies to exchange coefficients CH and CM: + + ch = ch / wspd1i + cm = cm / wspd1i + ch2 = ch2 / wspd1i + cq2 = cq2 / wspd1i + + if(snwd > 0.) then + cm = min(0.01,cm) + ch = min(0.01,ch) + ch2 = min(0.01,ch2) + cq2 = min(0.01,cq2) + end if + + endif ! 4 + + ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) + + if(opt_sfc == 4) then + ramb = max(1.,1./(cm*wspd1i) ) + rahb = max(1.,1./(ch*wspd1i) ) + endif + rawb = rahb ! es and d(es)/dt evaluated at tg @@ -1264,6 +1350,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso estg = esati end if qsfc = 0.622*(estg*rhsur)/(sfcprs-0.378*(estg*rhsur)) + qfx = (qsfc-qair)*cev*gamma/cpair end do loop3 ! end stability iteration end if @@ -1362,6 +1449,12 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! 2m air temperature ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2b = ehb2 + + if (opt_sfc == 4) then + ehb2 = ch2 * wspd1i ! need conductance,z0h from sfcdif4 + cq2b = cq2 * wspd1i ! conductance + endif + if (ehb2.lt.1.e-5 ) then t2mb = tgb q2b = qsfc From 56142b2ed549b57a02b165797ddc67161a1548ba Mon Sep 17 00:00:00 2001 From: rongqian yang Date: Fri, 18 Mar 2022 19:14:16 +0000 Subject: [PATCH 123/217] Noah MP non-glacier changes for MYNN --- physics/module_sf_noahmplsm.f90 | 1436 ++++++++++++++++++++++++++++++- 1 file changed, 1403 insertions(+), 33 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index ef022b4ee..09faf0e05 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -10,10 +10,22 @@ module module_sf_noahmplsm use machine , only : kind_phys use sfc_diff, only : stability + use physcons, only : rcp => con_rocp, & + & ep_1 => con_fvirt, & + & ep_2 => con_eps, & + & r_d => con_rd, & + & cp => con_cp, & + & g => con_g, & + & xlv => con_hvap + + implicit none public :: noahmp_options public :: noahmp_sflx + public :: sfcdif4 + public :: psi_init + private :: atm private :: phenology @@ -373,6 +385,32 @@ module module_sf_noahmplsm end type noahmp_parameters +! +! for sfcdif4 +! + real, parameter :: prt=1. !prandtl number + real, parameter :: p1000mb = 100000. + + real, parameter :: svp1 = 0.6112 + real, parameter :: svp2 = 17.67 + real, parameter :: svp3 = 29.65 + real, parameter :: svpt0 = 273.15 + real, parameter :: ep_3=1.-ep_2 + real, parameter :: ep2=ep_2 + real, parameter :: onethird = 1./3. + real, parameter :: sqrt3 = 1.7320508075688773 + real, parameter :: atan1 = 0.785398163397 !in radians + + real, parameter :: karman = 0.4 + real, parameter :: vconvc=1.25 + + real, parameter :: snowz0 = 0.011 + real, parameter :: wmin = 0.1 + + real, dimension(0:1000 ),save :: psim_stab,psim_unstab, & + psih_stab,psih_unstab + + contains ! !== begin noahmp_sflx ============================================================================== @@ -385,6 +423,7 @@ subroutine noahmp_sflx (parameters, & smceq , & ! in : vegetation/soil characteristics sfctmp , sfcprs , psfc , uu , vv , q2, garea1 , & ! in : forcing qc , soldn , lwdn,thsfc_loc, prslkix,prsik1x,prslk1x,& ! in : forcing + pblhx , iz0tlnd , itime ,psi_opt ,& prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing albold , sneqvo , & ! in/out : @@ -448,6 +487,11 @@ subroutine noahmp_sflx (parameters, & real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function real (kind=kind_phys) , intent(in) :: garea1 ! in exner function + real (kind=kind_phys) , intent(in) :: pblhx ! pbl height + integer , intent(in) :: iz0tlnd !< z0t option + integer , intent(in) :: itime !< + integer , intent(in) :: psi_opt !< + real (kind=kind_phys) , intent(inout) :: zlvl !< reference height (m) real (kind=kind_phys) , intent(in) :: cosz !< cosine solar zenith angle [0-1] real (kind=kind_phys) , intent(in) :: tbot !< bottom condition for soil temp. [k] @@ -682,8 +726,6 @@ subroutine noahmp_sflx (parameters, & logical :: crop_active !< flag to run crop model ! add canopy heat storage (C.He added based on GY Niu's communication) real :: canhs ! canopy heat storage change w/m2 -! maximum lai/sai used for some parameterizations based on plant growthi - ! intent (out) variables need to be assigned a value. these normally get assigned values ! only if dveg == 2. @@ -734,7 +776,7 @@ subroutine noahmp_sflx (parameters, & ! vegetation phenology call phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai ,igs, pgs) + lai , sai , troot , elai , esai ,igs, pgs) !input gvf should be consistent with lai if(dveg == 1 .or. dveg == 6 .or. dveg == 7) then @@ -778,10 +820,11 @@ subroutine noahmp_sflx (parameters, & sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in + pblhx ,iz0tlnd, itime ,psi_opt, & z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out @@ -1057,7 +1100,7 @@ end subroutine atm !!vegetation phenology considering vegetation canopy being buried by snow and !!evolution in time. subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai , igs, pgs) + lai , sai , troot , elai , esai , igs, pgs) ! -------------------------------------------------------------------------------------------------- ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time @@ -1616,10 +1659,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in + pblhx , iz0tlnd, itime,psi_opt, & z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out @@ -1700,6 +1744,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function real (kind=kind_phys) , intent(in) :: garea1 + real (kind=kind_phys) , intent(in) :: pblhx ! pbl height + integer , intent(in) :: iz0tlnd + integer , intent(in) :: itime + integer , intent(in) :: psi_opt + real (kind=kind_phys) , intent(in) :: qair !specific humidity (kg/kg) real (kind=kind_phys) , intent(in) :: sfctmp !air temperature (k) real (kind=kind_phys) , intent(in) :: thair !potential temperature (k) @@ -2041,7 +2090,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , & !in + lat ,z0m ,zlvl ,vegtyp , fveg, & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2173,6 +2222,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in + pblhx ,iz0tlnd ,itime ,psi_opt , & eah ,tah ,tv ,tgv ,cmv, ustarx , & !inout #ifdef CCPP chv ,dx ,dz8w ,errmsg ,errflg , & !inout @@ -2209,6 +2259,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in emg ,stc ,df ,rsurf ,latheag , & !in gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in + pblhx ,iz0tlnd ,itime ,psi_opt , & #ifdef CCPP tgb ,cmb ,chb, ustarx,errmsg ,errflg , & !inout #else @@ -2261,6 +2312,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc q2e = fveg * q2v + (1.0 - fveg) * q2b +! effectibe skin temperature + + ts = (fveg*chv*tah + (1.0-fveg)*chb*tgb ) / ch + + ! new coupling code if (opt_trs == 1) then @@ -2431,7 +2487,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , & !in + lat ,z0m ,zlvl ,vegtyp , fveg,& !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2456,7 +2512,8 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: lat !latitude (radians) real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) - integer , intent(in) :: vegtyp !vegtyp type + integer , intent(in) :: vegtyp !vegtyp type + real (kind=kind_phys), intent(in) :: fveg !green vegetation fraction [0.0-1.0] ! outputs real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] @@ -2505,6 +2562,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) + df(1) = df(1) * exp (sbeta * fveg) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -3650,7 +3708,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in - fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -3658,6 +3716,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in + pblhx ,iz0tlnd ,itime ,psi_opt , & eah ,tah ,tv ,tg ,cm,ustarx,& !inout #ifdef CCPP ch ,dx ,dz8w ,errmsg ,errflg , & !inout @@ -3705,6 +3764,12 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in) :: dt !time step (s) real (kind=kind_phys), intent(in) :: fsno !snow fraction + real (kind=kind_phys) , intent(in) :: pblhx ! pbl height + integer , intent(in) :: iz0tlnd + integer , intent(in) :: itime + integer , intent(in) :: psi_opt + + real (kind=kind_phys), intent(in) :: snowh !actual snow depth [m] real (kind=kind_phys), intent(in) :: fwet !wetted fraction of canopy real (kind=kind_phys), intent(in) :: cwp !canopy wind parameter @@ -3788,6 +3853,10 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: wspd ! ------------------------ local variables ---------------------------------------------------- + real (kind=kind_phys) :: gdx !grid dx + real (kind=kind_phys) :: snwd ! snowdepth in mm + integer :: mnice ! MYNN ice flag + real (kind=kind_phys) :: cw !water vapor exchange coefficient real (kind=kind_phys) :: fv !friction velocity (m/s) real (kind=kind_phys) :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2) @@ -3850,6 +3919,15 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: ch2 !surface exchange at 2m real (kind=kind_phys) :: thstar !surface exchange at 2m + real (kind=kind_phys) :: fm10 + real (kind=kind_phys) :: rb1v + real (kind=kind_phys) :: stress1v + + + real (kind=kind_phys) :: flhcv ! for MYNN + real (kind=kind_phys) :: flqcv ! for MYNN + real (kind=kind_phys) :: wspdv ! for MYNN + real (kind=kind_phys) :: thvair real (kind=kind_phys) :: thah real (kind=kind_phys) :: rahc2 !aerodynamic resistance for sensible heat (s/m) @@ -3979,6 +4057,16 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 cir = (2.-emv*(1.-emg))*emv*sb +! + gdx = sqrt(garea1) + snwd = snowh * 1000.0 + + if (snowh .gt. 0.1) then + mnice = 1 + else + mnice = 0 + endif + ! --------------------------------------------------------------------------------------------- loop1: do iter = 1, niterc ! begin stability iteration @@ -4032,14 +4120,41 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,.true. ,vaie ,vegtyp, & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out endif + if(opt_sfc == 4) then + + call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , & + sfcprs ,psfc ,pblhx ,gdx ,z0m , & + itime ,snwd ,mnice ,psi_opt, & + tah ,qair ,zlvl ,iz0tlnd,qsfc , & + h ,qfx ,cm ,ch ,ch2v , & + cq2v ,moz ,fv ,rb1v, fm, fh, & + stress1v,fm10 ,fh2 ,wspdv ,flhcv ,flqcv) + + + ! Undo the multiplication by windspeed that SFCDIF4 + ! applies to exchange coefficients CH and CM + + ch = ch / wspdv + cm = cm / wspdv + ch2v = ch2v / wspdv + + endif + + ramc = max(1.,1./(cm*ur)) rahc = max(1.,1./(ch*ur)) + + if (opt_sfc == 4 ) then + ramc = max(1.,1./(cm*wspdv) ) + rahc = max(1.,1./(ch*wspdv) ) + endif + rawc = rahc ! aerodyn resistance between heights z0g and d+z0v, rag, and leaf @@ -4149,6 +4264,11 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! consistent specific humidity from canopy air vapor pressure qsfc = (0.622*eah)/(sfcprs-0.378*eah) + if ( opt_sfc == 4 ) then + qfx = (qsfc-qair)*rhoair*caw + endif + + if (liter == 1) then exit loop1 endif @@ -4228,6 +4348,15 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & cah2 = fv*vkc/log((2.+z0h)/z0h) cah2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2v = cah2 + endif + + if (opt_sfc == 4 ) then + rahc2 = max(1.,1./(ch2v*wspdv)) + rawc2 = rahc2 + cah2 = 1./rahc2 + cq2v = 1./max(1.,1./(cq2v*wspdv)) + endif + if (cah2 .lt. 1.e-5 ) then t2mv = tah ! q2v = (eah*0.622/(sfcprs - 0.378*eah)) @@ -4237,7 +4366,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! q2v = (eah*0.622/(sfcprs - 0.378*eah))- qfx/(rhoair*fv)* 1./vkc * log((2.+z0h)/z0h) q2v = qsfc - ((evc+tr)/fveg+evg)/(latheav*rhoair) * 1./cq2v endif - endif ! update ch for output ch = cah @@ -4258,6 +4386,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & emg ,stc ,df ,rsurf ,lathea , & !in gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in + pblhx , iz0tlnd , itime ,psi_opt ,& #ifdef CCPP tgb ,cm ,ch,ustarx,errmsg ,errflg , & !inout #else @@ -4310,6 +4439,12 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) real (kind=kind_phys), intent(in) :: fsno !snow fraction + real (kind=kind_phys), intent(in) :: pblhx !pbl height (m) + integer, intent(in) :: iz0tlnd + integer, intent(in) :: itime + integer, intent(in) :: psi_opt + + !jref:start; in integer , intent(in) :: ivgtyp real (kind=kind_phys) , intent(in) :: qc !cloud water mixing ratio @@ -4351,6 +4486,19 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! local variables + real (kind=kind_phys) :: gdx !grid dx + real (kind=kind_phys) :: snwd ! snowdepth in mm + integer :: mnice ! MYNN ice flag + + real (kind=kind_phys) :: fm10 + real (kind=kind_phys) :: rb1b + real (kind=kind_phys) :: stress1b + + real (kind=kind_phys) :: wspdb + real (kind=kind_phys) :: flhcb + real (kind=kind_phys) :: flqcb +! + real (kind=kind_phys) :: taux !wind stress: e-w (n/m2) real (kind=kind_phys) :: tauy !wind stress: n-s (n/m2) real (kind=kind_phys) :: fira !total net longwave rad (w/m2) [+ to atm] @@ -4449,6 +4597,15 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & cir = emg*sb cgh = 2.*df(isnow+1)/dzsnso(isnow+1) + gdx = sqrt(garea1) + snwd = snowh * 1000.0 + + if (snowh .gt. 0.1) then + mnice = 1 + else + mnice = 0 + endif + ! ----------------------------------------------------------------- loop3: do iter = 1, niterb ! begin stability iteration @@ -4492,14 +4649,47 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,fveg ,garea1 ,.false. ,0.0,ivgtyp , & !in + zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 ,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out endif + if(opt_sfc == 4) then + + call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , & + sfcprs ,psfc ,pblhx ,gdx ,z0m , & + itime ,snwd ,mnice ,psi_opt , & + tgb ,qair ,zlvl ,iz0tlnd,qsfc , & + h ,qfx ,cm ,ch ,ch2b , & + cq2b ,moz ,fv ,rb1b, fm, fh , & + stress1b,fm10 ,fh2 , wspdb ,flhcb ,flqcb) + + ! Undo the multiplication by windspeed that SFCDIF4 + ! applies to exchange coefficients CH and CM: + + ch = ch / wspdb + cm = cm / wspdb + ch2b = ch2b / wspdb + cq2b = cq2b / wspdb + + if(snwd > 0.) then + cm = min(0.01,cm) + ch = min(0.01,ch) + ch2b = min(0.01,ch2b) + cq2b = min(0.01,cq2b) + end if + + endif ! 4 + ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) + + if(opt_sfc == 4) then + ramb = max(1.,1./(cm*wspdb) ) + rahb = max(1.,1./(ch*wspdb) ) + endif + rawb = rahb !jref - variables for diagnostics @@ -4581,6 +4771,13 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ehb2 = fv*vkc/log((2.+z0h)/z0h) ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2b = ehb2 + endif + + if(opt_sfc == 4) then + ehb2 = 1. /(max(1.,1./ch2b*wspdb)) + cq2b = 1. /(max(1.,1./cq2b*wspdb)) + endif + if (ehb2.lt.1.e-5 ) then t2mb = tgb q2b = qsfc @@ -4589,7 +4786,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) endif if (parameters%urban_flag) q2b = qsfc - end if ! update ch ch = ehb @@ -5095,7 +5291,7 @@ end subroutine sfcdif2 !! compute surface drag coefficient cm for momentum and ch for heat. subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,vegetated,vaie,vegtyp , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie ,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf ,cm ,ch ) !out @@ -5151,28 +5347,12 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys) :: czil1 ! canopy based czil real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output real (kind=kind_phys) :: sigmaa ! momentum partition parameter - real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx,slaifrac + real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 - real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! ------------------------------------------------------------------------------------------------- fv = ustarx - laimax = maxval(parameters%laim) - saimax = maxval(parameters%saim) - if(dveg.eq.4 .or. dveg.eq.5) then - if(laimax+saimax .gt. 0 .and. fveg .gt. 0) then - slaifrac=vaie/(laimax+saimax) - slaifrac=min(slaifrac,1.) - slaifrac=fveg*slaifrac - else - slaifrac=0.1_kind_phys - endif - else - slaifrac=fveg - endif - ! fv = ur*vkc/log((zlvl-zpd)/z0m) if(vegetated) then @@ -5223,7 +5403,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(slaifrac, 0.1_kind_phys) + tem2 = max(fveg, 0.1_kind_phys) zvfun1 = sqrt(tem1 * tem2) gdx = sqrt(garea1) @@ -9757,5 +9937,1195 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc end subroutine noahmp_options + subroutine sfcdif4(iloc ,jloc ,ux ,vx ,t1d , & + p1d ,psfcpa,pblhx ,dx ,znt , & + itime ,snwh ,isice ,psi_opt, & + tsk ,qx ,zlvl ,iz0tlnd,qsfc , & + hfx ,qfx ,cm ,chs ,chs2 , & + cqs2 , & + rmolx ,ust , rbx, fmx, fhx,stressx,& + fm10x, fh2x, wspdx,flhcx,flqcx) + + + +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- + +! input + + integer,intent(in ) :: iloc + integer,intent(in ) :: jloc + integer, intent(in) :: itime + + integer, intent(in) :: psi_opt + + integer, intent(in) :: isice ! for the glacier/snowh > 0.1m + + real, intent(in ) :: pblhx ! planetary boundary layer height + real, intent(in ) :: tsk ! skin temperature + real, intent(in ) :: psfcpa ! pressure in pascal + real, intent(in ) :: p1d !lowest model layer pressure (pa) + real, intent(in ) :: t1d !lowest model layer temperature + real, intent(in ) :: qx !water vapor specific humidity (kg/kg) from input + real, intent(in ) :: zlvl ! thickness of lowest full level layer + real, intent(in ) :: hfx ! sensible heat flux + real, intent(in ) :: qfx ! moisture flux + real, intent(in ) :: dx ! horisontal grid spacing + real, intent(in ) :: ux ! u and v winds + real, intent(in ) :: vx + real, intent(in ) :: znt ! z0m in m or inout + real, intent(in ) :: snwh ! in mm + +! optional vars + + integer,optional,intent(in ) :: iz0tlnd + + real, intent(inout) :: qsfc + real, intent(inout) :: ust + real, intent(inout) :: chs + real, intent(inout) :: chs2 + real, intent(inout) :: cqs2 + real, intent(inout) :: cm + + real, intent(inout) :: rmolx + real, intent(inout) :: rbx + real, intent(inout) :: fmx + real, intent(inout) :: fhx + real, intent(inout) :: stressx + real, intent(inout) :: fm10x + real, intent(inout) :: fh2x + + real, intent(inout) :: wspdx + real, intent(inout) :: flhcx + real, intent(inout) :: flqcx + + real :: zolx + real :: molx + +! diagnostics out +! real, intent(out) :: u10 +! real, intent(out) :: v10 +! real, intent(out) :: th2 +! real, intent(out) :: t2 +! real, intent(out) :: q2 +! real, intent(out) :: qsfc + + +! local + + real :: za ! height of full-sigma level + real :: thvx ! virtual potential temperature + real :: zqkl ! height of upper half level + real :: zqklp1 ! height of lower half level (surface) + real :: thx ! potential temperature + real :: psih ! similarity function for heat + real :: psih2 ! similarity function for heat 2m + real :: psih10 ! similarity function for heat 10m + real :: psim ! similarity function for momentum + real :: psim2 ! similarity function for momentum 2m + real :: psim10 ! similarity function for momentum 10m + + real :: gz1oz0 ! log(za/z0) + real :: gz2oz0 ! log(z2/z0) + real :: gz10oz0 ! log(z10/z0) + + real :: rhox ! density + real :: govrth ! g/theta for stability l + real :: tgdsa ! tsk + real :: tvir ! temporal variable src4 -> tvir + real :: thgb ! potential temperature ground + real :: psfcx ! surface pressure + real :: cpm + real :: qgh + + integer :: n,i,k,kk,l,nzol,nk,nzol2,nzol10 + + real :: zolzt, zolz0, zolza + real :: gz1ozt,gz2ozt,gz10ozt + + + real :: pl,thcon,tvcon,e1 + real :: zl,tskv,dthvdz,dthvm,vconv,rzol,rzol2,rzol10,zol2,zol10 + real :: dtg,psix,dtthx,psix10,psit,psit2,psiq,psiq2,psiq10 + real :: fluxc,vsgd,z0q,visc,restar,czil,restar2 + + real :: dqg + real :: tabs + real :: qsfcmr + real :: t1dc + real :: zt + real :: zq + real :: zratio + real :: qstar +!------------------------------------------------------------------- + + psfcx=psfcpa/1000. ! to kPa for saturation check + + if (itime == 1) then !init SP, MR + if (isice == 0) then + tabs = 0.5*(tsk + t1d) + if (tabs .lt. 273.15) then + !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) + e1=svp1*exp(4648*(1./273.15 - 1./tabs) - & + & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs)) + else + !saturation vapor pressure wrt water (bolton 1980) + e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3)) + endif + + qsfc =ep2*e1/(psfcx-ep_3*e1) !avg with the input? + qsfcmr =qsfc/(1.-qsfc) !to mixing ratio + endif + + if (isice == 1) then + if (tsk .lt. 273.15) then + !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) + e1=svp1*exp(4648*(1./273.15 - 1./tsk) - & + & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk)) + else + !saturation vapor pressure wrt water (bolton 1980) + e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3)) + endif + + qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity + qsfcmr=ep2*e1/(psfcx-e1) !mixing ratio + + endif + + else + ! use what comes out of the lsm + if (isice == 0) then + tabs = 0.5*(tsk + t1d) + if (tabs .lt. 273.15) then + !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) + e1=svp1*exp(4648*(1./273.15 - 1./tabs) - & + & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs)) + else + !saturation vapor pressure wrt water (bolton 1980) + e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3)) + endif + + qsfc =ep2*e1/(psfcx-ep_3*e1) ! avg with previous qsfc? + qsfcmr=qsfc/(1.-qsfc) + + endif + + if (isice == 1) then + if (tsk .lt. 273.15) then + !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) + e1=svp1*exp(4648*(1./273.15 - 1./tsk) - & + & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk)) + else + !saturation vapor pressure wrt water (bolton 1980) + e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3)) + endif + + qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity + qsfcmr=qsfc/(1.-qsfc) + + endif + + endif !done INIT if itime=1 +! convert (tah or tgb = tsk) temperature to potential temperature. + tgdsa = tsk + thgb = tsk*(p1000mb/psfcpa)**rcp !psfcpa is pa + +! store virtual, virtual potential and potential temperature + + pl = p1d/1000. + thx = t1d*(p1000mb*0.001/pl)**rcp + t1dc = t1d - 273.15 + + thvx = thx*(1.+ep_1*qx) !qx is SH from input + tvir = t1d*(1.+ep_1*qx) + + rhox=psfcx*1000./(r_d*tvir) + govrth=g/thx + za = zlvl + + !za=0.5*dz8w + + +! directly from input; check units + +! qfx = qflx * rhox +! hfx = hflx * rhox * cp + + + +! q2sat = qgh in lsm +!jref: canres and esat is calculated in the loop so should that be changed?? +! qgh=ep_2*e1/(pl-e1) +! cpm=cp*(1.+0.8*qx) + + +! qgh changed to use lowest-level air temp + + if (t1d .lt. 273.15) then + !saturation vapor pressure wrt ice + e1=svp1*exp(4648.*(1./273.15 - 1./t1d) - & + & 11.64*log(273.15/t1d) + 0.02265*(273.15 - t1d)) + else + !saturation vapor pressure wrt water (bolton 1980) + e1=svp1*exp(svp2*(t1d-svpt0)/(t1d-svp3)) + endif + + + !qgh=ep2*e1/(pl-ep_3*e1) !specific humidity + + qgh=ep2*e1/(pl-e1) !sat. mixing ratio ? + +! cpm=cp*(1.+0.84*qx) ! qx is SH + cpm=cp*(1.+0.84*qx/(1.0-qx) ) + + wspdx=sqrt(ux*ux+vx*vx) + + tskv=thgb*(1.+ep_1*qsfc) !avg with tsurf not used + dthvdz=(thvx-tskv) + + fluxc = max(hfx/rhox/cp + ep_1*tskv*qfx/rhox,0.) !hfx + qfx are fluxes units: wm^-2 and kg m^-2 s^-1 +! vconv = vconvc*(g/tgdsa*pblh*fluxc)**.33 + + vconv = vconvc*(g/tgdsa*min(1.5*pblhx,4000.0)*fluxc)**.33 !wstar +! vsgd = 0.32 * (max(dx/5000.-1.,0.))**.33 + + vsgd = min(0.32 * (max(dx/5000.-1.,0.))**.33,0.5) + wspdx=sqrt(wspdx*wspdx+vconv*vconv+vsgd*vsgd) + wspdx=max(wspdx,0.1) !0.1 is wmin + rbx=govrth*za*dthvdz/(wspdx*wspdx) !buld rich # + + if (itime == 1) then + rbx=max(rbx,-2.0) + rbx=min(rbx, 2.0) + else + rbx=max(rbx,-4.0) + rbx=min(rbx, 4.0) + endif + + +! visc=(1.32+0.009*(t1d-273.15))*1.e-5 +! kinematic viscosity + + + visc=1.326e-5*(1. + 6.542e-3*t1dc + 8.301e-6*t1dc*t1dc & + - 4.84e-9*t1dc*t1dc*t1dc) + +!compute roughness reynolds number (restar) using default znt +!the GFS option has been removed + + restar=max(ust*znt/visc,0.1) + +! get zt, zq based on the input +! the GFS roughness option and spp_pbl have been removed + + if (snwh > 50. .or. isice == 1) then ! (mm) treat as snow cover - use andreas cover isice =1 + call andreas_2002(znt,visc,ust,zt,zq) + else + if ( present(iz0tlnd) ) then + if ( iz0tlnd .le. 1 ) then + call zilitinkevich_1995(znt,zt,zq,restar,& + ust,karman,1.0,iz0tlnd,0,0.0) + elseif ( iz0tlnd .eq. 2 ) then + call yang_2008(znt,zt,zq,ust,molx,& + qstar,restar,visc) + elseif ( iz0tlnd .eq. 3 ) then + !original mynn in wrf-arw used this form: + call garratt_1992(zt,zq,znt,restar,1.0) + endif + +! the GFS option is removed along with gfs_z0_lnd + + else + + !default to zilitinkevich + call zilitinkevich_1995(znt,zt,zq,restar,& + ust,karman,1.0,0,0,0.0) + endif + endif + + +! --------- +! calculate bulk richardson no. of surface layer, +! according to akb(1976), eq(12). + + gz1oz0= log((za+znt)/znt) + gz1ozt= log((za+znt)/zt) + gz2oz0= log((2.0+znt)/znt) + gz2ozt= log((2.0+znt)/zt) + gz10oz0=log((10.+znt)/znt) +! gz10ozt=log((10.+znt)/zt) + + zratio=znt/zt !need estimate for li et al. + + +! vconv = 0.25*sqrt(g/tskv*pblh(i)*dthvm) +! if(mol.lt.0.) br=amin1(br,0.0) -> check the input mol later +! rmol=-govrth*dthvdz*za*karman + + if (rbx .gt. 0.0) then + + !compute z/l first guess: + call li_etal_2010(zolx,rbx,za/znt,zratio) + !zol=za*karman*g*mol/(thx*max(ust*ust,0.0001)) + zolx=max(zolx,0.0) + zolx=min(zolx,20.) + + + !use pedros iterative function to find z/l + !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt) + !use brute-force method + + zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt) + zolx=max(zolx,0.0) + zolx=min(zolx,20.) + + zolzt = zolx*zt/za ! zt/l + zolz0 = zolx*znt/za ! z0/l + zolza = zolx*(za+znt)/za ! (z+z0/l + zol10 = zolx*(10.+znt)/za ! (10+z0)/l + zol2 = zolx*(2.+znt)/za ! (2+z0)/l + + !compute psim and psih + !call psi_beljaars_holtslag_1991(psim,psih,zol) + !call psi_businger_1971(psim,psih,zol) + !call psi_zilitinkevich_esau_2007(psim,psih,zol) + !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za) + !call psi_cb2005(psim,psih,zolza,zolz0) + + psim=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) + psih=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) + psim10=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) +! psih10=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) + psih2=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt) + + ! 1.0 over monin-obukhov length + + rmolx= zolx/za + + elseif(rbx .eq. 0.) then + !========================================================= + !-----class 3; forced convection/neutral: + !========================================================= + + psim=0.0 + psih=psim + psim10=0. +! psih10=0. + psih2=0. + + zolx =0. + rmolx =0. + + elseif(rbx .lt. 0.)then + !========================================================== + !-----class 4; free convection: + !========================================================== + + !compute z/l first guess: + + call li_etal_2010(zolx,rbx,za/znt,zratio) + + !zol=za*karman*g*mol/(th1d*max(ust_lnd*ust_lnd,0.001)) + + zolx=max(zolx,-20.0) + zolx=min(zolx,0.0) + + + !use pedros iterative function to find z/l + !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt) + !use brute-force method + + zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt) + zolx=max(zolx,-20.0) + zolx=min(zolx,0.0) + + zolzt = zolx*zt/za ! zt/l + zolz0 = zolx*znt/za ! z0/l + zolza = zolx*(za+znt)/za ! (z+z0/l + zol10 = zolx*(10.+znt)/za ! (10+z0)/l + zol2 = zolx*(2.+znt)/za ! (2+z0)/l + + !compute psim and psih + !call psi_hogstrom_1996(psim,psih,zol, zt_lnd, zntstoch_lnd, za) + !call psi_businger_1971(psim,psih,zol) + !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za) + ! use tables + + psim=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) + psih=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) + psim10=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) +! psih10=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) + psih2=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt) + + !---limit psih and psim in the case of thin layers and + !---high roughness. this prevents denominator in fluxes + !---from getting too small + + psih=min(psih,0.9*gz1ozt) + psim=min(psim,0.9*gz1oz0) + psih2=min(psih2,0.9*gz2ozt) + psim10=min(psim10,0.9*gz10oz0) +! psih10=min(psih10,0.9*gz10ozt) + + rmolx = zolx/za + + endif + + ! calculate the resistance: + + psix =max(gz1oz0-psim, 1.0) + psix10=max(gz10oz0-psim10, 1.0) + psit =max(gz1ozt-psih , 1.0) + psit2 =max(gz2ozt-psih2, 1.0) + psiq =max(log((za+zq)/zq)-psih ,1.0) + psiq2 =max(log((2.0+zq)/zq)-psih2 ,1.0) + + !------------------------------------------------------------ + !-----compute the frictional velocity: + !------------------------------------------------------------ + + + ! to prevent oscillations average with old value + +! oldust = ust + + ust=0.5*ust+0.5*karman*wspdx/psix + ust=max(ust,0.005) + +! stress=ust**2 + + !set ustm = ust over land. + +! ustmx=ust + + + !---------------------------------------------------- + !----compute the temperature scale (a.k.a. friction temperature, t*, or mol) + !----and compute the moisture scale (or q*) + !---------------------------------------------------- + + dtg=thvx-tskv + +! oldtst=mol + + molx=karman*dtg/psit/prt !T* + + !t_star = -hfx/(ust*cpm*rho1d) + !t_star = mol + !---------------------------------------------------- + ! dqg=(qvsh-qsfc)*1000. !(kg/kg -> g/kg) + + dqg=(qx-qsfc)*1000. !(kg/kg -> g/kg) + qstar=karman*dqg/psiq/prt + + cm = (karman/psix)*(karman/psix)*wspdx + +! cm = (karman/psix)*(karman/psix) +! ch = (karman/psix)*(karman/psit) + + chs=ust*karman/psit + cqs2=ust*karman/psiq2 + chs2=ust*karman/psit2 + +! u10=ux*psix10/psix +! v10=vx*psix10/psix + + flhcx = rhox*cpm*ust*karman/psit + flqcx = rhox*1.0*ust*karman/psiq + +! ch = flhcx/(cpm*rhox) !same chs + + fmx = psix + fhx = psit + fm10x = psix10 + fh2x =psit2 + +! ustmx = ust + + stressx = ust**2 ! or cm*wind*wind + + end subroutine sfcdif4 + + subroutine zilitinkevich_1995(z_0,zt,zq,restar,ustar,karman,& + & landsea,iz0tlnd2,spp_pbl,rstoch) + + implicit none + real, intent(in) :: z_0,restar,ustar,karman,landsea + integer, optional, intent(in):: iz0tlnd2 + real, intent(out) :: zt,zq + real :: czil !=0.100 in chen et al. (1997) + !=0.075 in zilitinkevich (1995) + !=0.500 in lemone et al. (2008) + integer, intent(in) :: spp_pbl + real, intent(in) :: rstoch + + + if (landsea-1.5 .gt. 0) then !water + + !this is based on zilitinkevich, grachev, and fairall (2001; + !their equations 15 and 16). + if (restar .lt. 0.1) then + zt = z_0*exp(karman*2.0) + zt = min( zt, 6.0e-5) + zt = max( zt, 2.0e-9) + zq = z_0*exp(karman*3.0) + zq = min( zq, 6.0e-5) + zq = max( zq, 2.0e-9) + else + zt = z_0*exp(-karman*(4.0*sqrt(restar)-3.2)) + zt = min( zt, 6.0e-5) + zt = max( zt, 2.0e-9) + zq = z_0*exp(-karman*(4.0*sqrt(restar)-4.2)) + zq = min( zt, 6.0e-5) + zq = max( zt, 2.0e-9) + endif + + else !land + + !option to modify czil according to chen & zhang, 2009 + if ( iz0tlnd2 .eq. 1 ) then + czil = 10.0 ** ( -0.40 * ( z_0 / 0.07 ) ) + else + czil = 0.085 !0.075 !0.10 + end if + + zt = z_0*exp(-karman*czil*sqrt(restar)) + zt = min( zt, 0.75*z_0) + + zq = z_0*exp(-karman*czil*sqrt(restar)) + zq = min( zq, 0.75*z_0) + +! stochastically perturb thermal and moisture roughness length. +! currently set to half the amplitude: + if (spp_pbl==1) then + zt = zt + zt * 0.5 * rstoch + zt = max(zt, 0.0001) + zq = zt + endif + + endif + + return + + end subroutine zilitinkevich_1995 + +!!data. the formula for land uses a constant ratio (z_0/7.4) taken +!!from garratt (1992). + subroutine garratt_1992(zt,zq,z_0,ren,landsea) + + implicit none + real, intent(in) :: ren, z_0,landsea + real, intent(out) :: zt,zq + real :: rq + real, parameter :: e=2.71828183 + + if (landsea-1.5 .gt. 0) then !water + + zt = z_0*exp(2.0 - (2.48*(ren**0.25))) + zq = z_0*exp(2.0 - (2.28*(ren**0.25))) + + zq = min( zq, 5.5e-5) + zq = max( zq, 2.0e-9) + zt = min( zt, 5.5e-5) + zt = max( zt, 2.0e-9) !same lower limit as ecmwf + else !land + zq = z_0/(e**2.) !taken from garratt (1980,1992) + zt = zq + endif + + return + + end subroutine garratt_1992 +!-------------------------------------------------------------------- +!>\ingroup mynn_sfc +!> this is a modified version of yang et al (2002 qjrms, 2008 jamc) +!! and chen et al (2010, j of hydromet). although it was originally +!! designed for arid regions with bare soil, it is modified +!! here to perform over a broader spectrum of vegetation. +!! +!!the original formulation relates the thermal roughness length (zt) +!!to u* and t*: +!! +!! zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar)**0.25)) +!! +!!where ht = renc*visc/ustar and the critical reynolds number +!!(renc) = 70. beta was originally = 10 (2002 paper) but was revised +!!to 7.2 (in 2008 paper). their form typically varies the +!!ratio z0/zt by a few orders of magnitude (1-1e4). +!! +!!this modified form uses beta = 1.5 and a variable renc (function of z_0), +!!so zt generally varies similarly to the zilitinkevich form (with czil = 0.1) +!!for very small or negative surface heat fluxes but can become close to the +!!zilitinkevich with czil = 0.2 for very large hfx (large negative t*). +!!also, the exponent (0.25) on tstar was changed to 1.0, since we found +!!zt was reduced too much for low-moderate positive heat fluxes. +!! +!!this should only be used over land! + subroutine yang_2008(z_0,zt,zq,ustar,tstar,qst,ren,visc) + + implicit none + real, intent(in) :: z_0, ren, ustar, tstar, qst, visc + real :: ht, &! roughness height at critical reynolds number + tstar2, &! bounded t*, forced to be non-positive + qstar2, &! bounded q*, forced to be non-positive + z_02, &! bounded z_0 for variable renc2 calc + renc2 ! variable renc, function of z_0 + real, intent(out) :: zt,zq + real, parameter :: renc=300., & !old constant renc + beta=1.5, & !important for diurnal variation + m=170., & !slope for renc2 function + b=691. !y-intercept for renc2 function + + z_02 = min(z_0,0.5) + z_02 = max(z_02,0.04) + renc2= b + m*log(z_02) + ht = renc2*visc/max(ustar,0.01) + tstar2 = min(tstar, 0.0) + qstar2 = min(qst,0.0) + + zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar2)**1.0)) + zq = ht * exp(-beta*(ustar**0.5)*(abs(qstar2)**1.0)) + !zq = zt + + zt = min(zt, z_0/2.0) + zq = min(zq, z_0/2.0) + + return + + end subroutine yang_2008 + +!>\ingroup mynn_sfc +!> this is taken from andreas (2002; j. of hydromet) and +!! andreas et al. (2005; blm). +!! +!! this should only be used over snow/ice! + subroutine andreas_2002(z_0,bvisc,ustar,zt,zq) + + implicit none + real, intent(in) :: z_0, bvisc, ustar + real, intent(out) :: zt, zq + real :: ren2, zntsno + + real, parameter :: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, & + bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, & + bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183 + + real, parameter :: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, & + bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, & + bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180 + + !calculate zo for snow (andreas et al. 2005, blm) + zntsno = 0.135*bvisc/ustar + & + (0.035*(ustar*ustar)/9.8) * & + (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.) + ren2 = ustar*zntsno/bvisc + + ! make sure that re is not outside of the range of validity + ! for using their equations + if (ren2 .gt. 1000.) ren2 = 1000. + + if (ren2 .le. 0.135) then + + zt = zntsno*exp(bt0_s + bt1_s*log(ren2) + bt2_s*log(ren2)**2) + zq = zntsno*exp(bq0_s + bq1_s*log(ren2) + bq2_s*log(ren2)**2) + + else if (ren2 .gt. 0.135 .and. ren2 .lt. 2.5) then + + zt = zntsno*exp(bt0_t + bt1_t*log(ren2) + bt2_t*log(ren2)**2) + zq = zntsno*exp(bq0_t + bq1_t*log(ren2) + bq2_t*log(ren2)**2) + + else + + zt = zntsno*exp(bt0_r + bt1_r*log(ren2) + bt2_r*log(ren2)**2) + zq = zntsno*exp(bq0_r + bq1_r*log(ren2) + bq2_r*log(ren2)**2) + + endif + + return + + end subroutine andreas_2002 +!-------------------------------------------------------------------- +!>\ingroup mynn_sfc +!! this subroutine returns a more robust z/l that best matches +!! the z/l from hogstrom (1996) for unstable conditions and beljaars +!! and holtslag (1991) for stable conditions. + subroutine li_etal_2010(zl, rib, zaz0, z0zt) + + implicit none + real, intent(out) :: zl + real, intent(in) :: rib, zaz0, z0zt + real :: alfa, beta, zaz02, z0zt2 + real, parameter :: au11=0.045, bu11=0.003, bu12=0.0059, & + &bu21=-0.0828, bu22=0.8845, bu31=0.1739, & + &bu32=-0.9213, bu33=-0.1057 + real, parameter :: aw11=0.5738, aw12=-0.4399, aw21=-4.901,& + &aw22=52.50, bw11=-0.0539, bw12=1.540, & + &bw21=-0.669, bw22=-3.282 + real, parameter :: as11=0.7529, as21=14.94, bs11=0.1569,& + &bs21=-0.3091, bs22=-1.303 + + !set limits according to li et al (2010), p 157. + zaz02=zaz0 + if (zaz0 .lt. 100.0) zaz02=100. + if (zaz0 .gt. 100000.0) zaz02=100000. + + !set more limits according to li et al (2010) + z0zt2=z0zt + if (z0zt .lt. 0.5) z0zt2=0.5 + if (z0zt .gt. 100.0) z0zt2=100. + + alfa = log(zaz02) + beta = log(z0zt2) + + if (rib .le. 0.0) then + zl = au11*alfa*rib**2 + ( & + & (bu11*beta + bu12)*alfa**2 + & + & (bu21*beta + bu22)*alfa + & + & (bu31*beta**2 + bu32*beta + bu33))*rib + !if(zl .lt. -15 .or. zl .gt. 0.)print*,"violation rib<0:",zl + zl = max(zl,-15.) !limits set according to li et al (2010) + zl = min(zl,0.) !figure 1. + elseif (rib .gt. 0.0 .and. rib .le. 0.2) then + zl = ((aw11*beta + aw12)*alfa + & + & (aw21*beta + aw22))*rib**2 + & + & ((bw11*beta + bw12)*alfa + & + & (bw21*beta + bw22))*rib + !if(zl .lt. 0 .or. zl .gt. 4)print*,"violation 00.2:",zl + zl = min(zl,20.) !limits according to li et al (2010), thier + !figue 1c. + zl = max(zl,1.) + endif + + return + + end subroutine li_etal_2010 +!------------------------------------------------------------------- + real function zolri(ri,za,z0,zt,zol1,psi_opt) + + ! this iterative algorithm was taken from the revised surface layer + ! scheme in wrf-arw, written by pedro jimenez and jimy dudhia and + ! summarized in jimenez et al. (2012, mwr). this function was adapted + ! to input the thermal roughness length, zt, (as well as z0) and use initial + ! estimate of z/l. + + implicit none + real, intent(in) :: ri,za,z0,zt,zol1 + integer, intent(in) :: psi_opt + real :: x1,x2,fx1,fx2 + integer :: n + integer, parameter :: nmax = 20 + !real, dimension(nmax):: zlhux +! real :: zolri2 + + if (ri.lt.0.)then + x1=zol1 - 0.02 !-5. + x2=0. + else + x1=0. + x2=zol1 + 0.02 !5. + endif + + n=1 + fx1=zolri2(x1,ri,za,z0,zt,psi_opt) + fx2=zolri2(x2,ri,za,z0,zt,psi_opt) + + do while (abs(x1 - x2) > 0.01 .and. n < nmax) + if(abs(fx2).lt.abs(fx1))then + x1=x1-fx1/(fx2-fx1)*(x2-x1) + fx1=zolri2(x1,ri,za,z0,zt,psi_opt) + zolri=x1 + else + x2=x2-fx2/(fx2-fx1)*(x2-x1) + fx2=zolri2(x2,ri,za,z0,zt,psi_opt) + zolri=x2 + endif + n=n+1 + !print*," n=",n," x1=",x1," x2=",x2 + !zlhux(n)=zolri + enddo + + if (n==nmax .and. abs(x1 - x2) >= 0.01) then + !if convergence fails, use approximate values: + call li_etal_2010(zolri, ri, za/z0, z0/zt) + !zlhux(n)=zolri + !print*,"iter fail, n=",n," ri=",ri," z0=",z0 + else + !print*,"success,n=",n," ri=",ri," z0=",z0 + endif + + return + end function +!------------------------------------------------------------------- + real function zolri2(zol2,ri2,za,z0,zt,psi_opt) + + ! input: ================================= + ! zol2 - estimated z/l + ! ri2 - calculated bulk richardson number + ! za - 1/2 depth of first model layer + ! z0 - aerodynamic roughness length + ! zt - thermal roughness length + ! output: ================================ + ! zolri2 - delta ri + + implicit none + integer, intent(in) :: psi_opt + real, intent(in) :: ri2,za,z0,zt + real, intent(inout) :: zol2 + real :: zol20,zol3,psim1,psih1,psix2,psit2,zolt + +! real :: psih_unstable,psim_unstable,psih_stable, psim_stable + + if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 + + zol20=zol2*z0/za ! z0/l + zol3=zol2+zol20 ! (z+z0)/l + zolt=zol2*zt/za ! zt/l + + if (ri2.lt.0) then + !psix2=log((za+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) + !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + psit2=max(log((za+z0)/zt)-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) + psix2=max(log((za+z0)/z0)-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)),1.0) + else + !psix2=log((za+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) + !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + psit2=max(log((za+z0)/zt)-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) + psix2=max(log((za+z0)/z0)-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)),1.0) + endif + + zolri2=zol2*psit2/psix2**2 - ri2 + !print*," target ri=",ri2," est ri=",zol2*psit2/psix2**2 + + return + end function +!==================================================================== + + real function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) + + ! this iterative algorithm to compute z/l from bulk-ri + + implicit none + real, intent(in) :: ri,za,z0,zt,logz0,logzt + integer, intent(in) :: psi_opt + real, intent(inout) :: zol1 + real :: zol20,zol3,zolt,zolold + integer :: n + integer, parameter :: nmax = 20 + real, dimension(nmax):: zlhux + real :: psit2,psix2 + +! real :: psim_unstable, psim_stable +! real :: psih_unstable, psih_stable + + !print*,"+++++++incoming: z/l=",zol1," ri=",ri + if (zol1*ri .lt. 0.) then + !print*,"begin: wrong quadrants: z/l=",zol1," ri=",ri + zol1=0. + endif + + if (ri .lt. 0.) then + zolold=-99999. + zolrib=-66666. + else + zolold=99999. + zolrib=66666. + endif + n=1 + + do while (abs(zolold - zolrib) > 0.01 .and. n < nmax) + + if(n==1)then + zolold=zol1 + else + zolold=zolrib + endif + zol20=zolold*z0/za ! z0/l + zol3=zolold+zol20 ! (z+z0)/l + zolt=zolold*zt/za ! zt/l + !print*,"z0/l=",zol20," (z+z0)/l=",zol3," zt/l=",zolt + if (ri.lt.0) then + !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + !psit2=log((za+z0)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + psit2=max(logzt-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) + psix2=max(logz0-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)), 1.0) + else + !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + !psit2=log((za+z0)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + psit2=max(logzt-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) + psix2=max(logz0-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)), 1.0) + endif + !print*,"n=",n," psit2=",psit2," psix2=",psix2 + zolrib=ri*psix2**2/psit2 + zlhux(n)=zolrib + n=n+1 + enddo + + if (n==nmax .and. abs(zolold - zolrib) > 0.01 ) then + !print*,"iter fail, n=",n," ri=",ri," z/l=",zolri + !if convergence fails, use approximate values: + call li_etal_2010(zolrib, ri, za/z0, z0/zt) + zlhux(n)=zolrib + !print*,"failed, n=",n," ri=",ri," z0=",z0 + !print*,"z/l=",zlhux(1:nmax) + else + !if(zolrib*ri .lt. 0.) then + ! !print*,"end: wrong quadrants: z/l=",zolrib," ri=",ri + ! !call li_etal_2010(zolrib, ri, za/z0, z0/zt) + !endif + !print*,"success,n=",n," ri=",ri," z0=",z0 + endif + + return + end function +!==================================================================== + + subroutine psi_init(psi_opt,errmsg,errflg) + + integer :: n,psi_opt + real :: zolf + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + if (psi_opt == 0) then + do n=0,1000 + ! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full(zolf) + psih_stab(n)=psih_stable_full(zolf) + + ! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full(zolf) + psih_unstab(n)=psih_unstable_full(zolf) + enddo + else + do n=0,1000 + ! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full_gfs(zolf) + psih_stab(n)=psih_stable_full_gfs(zolf) + + ! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full_gfs(zolf) + psih_unstab(n)=psih_unstable_full_gfs(zolf) + enddo + endif + + !simple test to see if initialization worked: + if (psim_stab(1) < 0. .and. psih_stab(1) < 0. .and. & + psim_unstab(1) > 0. .and. psih_unstab(1) > 0.) then + errmsg = 'in mynn sfc, psi tables have been initialized' + errflg = 0 + else + errmsg = 'error in mynn sfc: problem initializing psi tables' + errflg = 1 + endif + + end subroutine psi_init +! ================================================================== +! ... integrated similarity functions from mynn... +! +!>\ingroup mynn_sfc + real function psim_stable_full(zolf) + real :: zolf + + !psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) + psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**0.4) + + return + end function + +!>\ingroup mynn_sfc + real function psih_stable_full(zolf) + real :: zolf + + !psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) + psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**0.9090909090909090909) + + return + end function + +!>\ingroup mynn_sfc + real function psim_unstable_full(zolf) + real :: zolf,x,ym,psimc,psimk + + x=(1.-16.*zolf)**.25 + !psimk=2*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan(1.) + psimk=2.*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan1 + + ym=(1.-10.*zolf)**onethird + !psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*atan((2.*ym+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.) + psimc=1.5*log((ym**2 + ym+1.)*onethird)-sqrt3*atan((2.*ym+1)/sqrt3)+4.*atan1/sqrt3 + + psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) + + return + end function + +!>\ingroup mynn_sfc + real function psih_unstable_full(zolf) + real :: zolf,y,yh,psihc,psihk + + y=(1.-16.*zolf)**.5 + !psihk=2.*log((1+y)/2.) + psihk=2.*log((1+y)*0.5) + + yh=(1.-34.*zolf)**onethird + !psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*atan((2.*yh+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.) + psihc=1.5*log((yh**2.+yh+1.)*onethird)-sqrt3*atan((2.*yh+1)/sqrt3)+4.*atan1/sqrt3 + + psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2) + + return + end function + +! ================================================================== +! ... integrated similarity functions from gfs... +! + real function psim_stable_full_gfs(zolf) + real :: zolf + real, parameter :: alpha4 = 20. + real :: aa + + aa = sqrt(1. + alpha4 * zolf) + psim_stable_full_gfs = -1.*aa + log(aa + 1.) + + return + end function + + real function psih_stable_full_gfs(zolf) + real :: zolf + real, parameter :: alpha4 = 20. + real :: bb + + bb = sqrt(1. + alpha4 * zolf) + psih_stable_full_gfs = -1.*bb + log(bb + 1.) + + return + end function + + real function psim_unstable_full_gfs(zolf) + real :: zolf + real :: hl1,tem1 + real, parameter :: a0=-3.975, a1=12.32, & + b1=-7.755, b2=6.041 + + if (zolf .ge. -0.5) then + hl1 = zolf + psim_unstable_full_gfs = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) + else + hl1 = -zolf + tem1 = 1.0 / sqrt(hl1) + psim_unstable_full_gfs = log(hl1) + 2. * sqrt(tem1) - .8776 + end if + + return + end function + + real function psih_unstable_full_gfs(zolf) + real :: zolf + real :: hl1,tem1 + real, parameter :: a0p=-7.941, a1p=24.75, & + b1p=-8.705, b2p=7.899 + + if (zolf .ge. -0.5) then + hl1 = zolf + psih_unstable_full_gfs = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) + else + hl1 = -zolf + tem1 = 1.0 / sqrt(hl1) + psih_unstable_full_gfs = log(hl1) + .5 * tem1 + 1.386 + end if + + return + end function + +!================================================================= +! look-up table functions - or, if beyond -10 < z/l < 10, recalculate +!================================================================= + real function psim_stable(zolf,psi_opt) + integer :: nzol,psi_opt + real :: rzol,zolf + + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) + else + if (psi_opt == 0) then + psim_stable = psim_stable_full(zolf) + else + psim_stable = psim_stable_full_gfs(zolf) + endif + endif + + return + end function + + real function psih_stable(zolf,psi_opt) + integer :: nzol,psi_opt + real :: rzol,zolf + + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) + else + if (psi_opt == 0) then + psih_stable = psih_stable_full(zolf) + else + psih_stable = psih_stable_full_gfs(zolf) + endif + endif + + return + end function + + real function psim_unstable(zolf,psi_opt) + integer :: nzol,psi_opt + real :: rzol,zolf + + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) + else + if (psi_opt == 0) then + psim_unstable = psim_unstable_full(zolf) + else + psim_unstable = psim_unstable_full_gfs(zolf) + endif + endif + + return + end function + + real function psih_unstable(zolf,psi_opt) + integer :: nzol,psi_opt + real :: rzol,zolf + + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) + else + if (psi_opt == 0) then + psih_unstable = psih_unstable_full(zolf) + else + psih_unstable = psih_unstable_full_gfs(zolf) + endif + endif + + return + end function +!======================================================================== end module module_sf_noahmplsm From f3af80f1545f17e34e2499b5d50d04b8adef5304 Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Sun, 20 Mar 2022 14:05:25 +0000 Subject: [PATCH 124/217] tuning cd/lm parameter --- physics/module_sf_noahmplsm.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 6e59407bb..d2f766b31 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4695,7 +4695,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - kh = max ( vkc*fv*(hcan-zpd)/fhgh, mpe ) + kh = max ( 0.5*vkc*fv*(hcan-zpd)/fhgh, mpe ) ramg = 0. rahg = tmprah2 / kh rawg = rahg From 96f58e021a1d5607a446dd0826982343929c72d5 Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Sun, 20 Mar 2022 14:07:49 +0000 Subject: [PATCH 125/217] tuning cd/lm parameter --- physics/module_sf_noahmplsm.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index d2f766b31..2f16dc331 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4686,7 +4686,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in fhgh = 0.5 * (fhgh+fhgnewh) endif - cwpc = (cwp * vai * hcan * fhg)**0.5 + cwpc = (0.5 * cwp * vai * hcan * fhg)**0.5 ! cwpc = (cwp*fhg)**0.5 tmp1 = exp( -cwpc*z0hg/hcan ) @@ -4695,7 +4695,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - kh = max ( 0.5*vkc*fv*(hcan-zpd)/fhgh, mpe ) + kh = max ( vkc*fv*(hcan-zpd)/fhgh, mpe ) ramg = 0. rahg = tmprah2 / kh rawg = rahg From a4cffec8ee55a7ef4e07043790bf3e43494de2ec Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sun, 20 Mar 2022 11:28:17 -0600 Subject: [PATCH 126/217] Import GFS_interstitial_type from CCPP_typedefs instead of GFS_typedefs --- physics/GFS_suite_interstitial.F90 | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 044912e07..5a8849f08 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -16,8 +16,9 @@ end subroutine GFS_suite_interstitial_rad_reset_finalize !! subroutine GFS_suite_interstitial_rad_reset_run (Interstitial, Model, errmsg, errflg) - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -52,8 +53,10 @@ end subroutine GFS_suite_interstitial_phys_reset_finalize !! subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Model, errmsg, errflg) - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type + use CCPP_typedefs, only: GFS_interstitial_type + implicit none @@ -89,7 +92,7 @@ end subroutine GFS_suite_interstitial_1_finalize subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, dxmin, dxinv, pgr, & islmsk, work1, work2, psurf, dudt, dvdt, dtdt, dqdt, errmsg, errflg) - use machine, only: kind_phys + use machine, only: kind_phys implicit none From 7fa72235c60977756e5fe0bd2b5310da38434d7b Mon Sep 17 00:00:00 2001 From: helin wei Date: Sun, 20 Mar 2022 17:36:27 +0000 Subject: [PATCH 127/217] revert back to shdfac in gvfun calculation due to occasional model crash --- physics/module_sf_noahmplsm.f90 | 24 ++++-------------------- 1 file changed, 4 insertions(+), 20 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index ef022b4ee..5e6e19f14 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4032,7 +4032,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,.true. ,vaie ,vegtyp, & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp, & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out @@ -4492,7 +4492,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,fveg ,garea1 ,.false. ,0.0,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out @@ -5151,28 +5151,12 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys) :: czil1 ! canopy based czil real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output real (kind=kind_phys) :: sigmaa ! momentum partition parameter - real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx,slaifrac + real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 - real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! ------------------------------------------------------------------------------------------------- fv = ustarx - laimax = maxval(parameters%laim) - saimax = maxval(parameters%saim) - if(dveg.eq.4 .or. dveg.eq.5) then - if(laimax+saimax .gt. 0 .and. fveg .gt. 0) then - slaifrac=vaie/(laimax+saimax) - slaifrac=min(slaifrac,1.) - slaifrac=fveg*slaifrac - else - slaifrac=0.1_kind_phys - endif - else - slaifrac=fveg - endif - ! fv = ur*vkc/log((zlvl-zpd)/z0m) if(vegetated) then @@ -5223,7 +5207,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(slaifrac, 0.1_kind_phys) + tem2 = max(fveg, 0.1_kind_phys) zvfun1 = sqrt(tem1 * tem2) gdx = sqrt(garea1) From 779b323d2f39d74319c9ff24a07aa7b577e018d5 Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Mon, 21 Mar 2022 15:00:51 +0000 Subject: [PATCH 128/217] modify a table of cwp parameter --- physics/module_sf_noahmplsm.f90 | 4 ++-- physics/noahmp_tables.f90 | 10 +++++----- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 2f16dc331..f6ec7b79e 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4686,7 +4686,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in fhgh = 0.5 * (fhgh+fhgnewh) endif - cwpc = (0.5 * cwp * vai * hcan * fhg)**0.5 + cwpc = (cwp * vai * hcan * fhg)**0.5 ! cwpc = (cwp*fhg)**0.5 tmp1 = exp( -cwpc*z0hg/hcan ) @@ -4695,7 +4695,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - kh = max ( vkc*fv*(hcan-zpd)/fhgh, mpe ) + kh = max ( vkc*fv*(hcan-zpd)/(max(fhgh,0.1), mpe ) ramg = 0. rahg = tmprah2 / kh rawg = rahg diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 9cb25b3f3..6666b2f67 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -510,11 +510,11 @@ module noahmp_tables ! real :: cwpvt_table(mvt) !< empirical canopy wind parameter - data ( cwpvt_table (i),i=1,mvt) / 0.18, 0.67, 0.18, 0.67, 0.29, 1.00, & - & 2.00, 1.30, 1.00, 5.00, 1.17, 1.67, & - & 1.67, 1.67, 0.18, 0.18, 0.18, 0.67, & - & 1.00, 0.18, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + data ( cwpvt_table (i),i=1,mvt) / 0.09, 0.335, 0.09, 0.335, 0.145, 0.50, & + & 1.00, 0.65, 0.50, 2.50, 0.585, 0.835, & + & 0.835, 0.835, 0.09, 0.09, 0.09, 0.335, & + & 0.835, 0.835, 0.09, 0.09, 0.09, 0.335, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / real :: wrrat_table(mvt) !< wood to non-wood ratio From 09e4f95feb79a9354c9fb3710567a3ec58a2da5d Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Mon, 21 Mar 2022 15:04:38 +0000 Subject: [PATCH 129/217] modify a table of cwp parameter --- physics/module_sf_noahmplsm.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index f6ec7b79e..217f4ce80 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4695,7 +4695,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - kh = max ( vkc*fv*(hcan-zpd)/(max(fhgh,0.1), mpe ) + kh = max ( vkc*fv*(hcan-zpd)/(max(fhgh,0.1)), mpe ) ramg = 0. rahg = tmprah2 / kh rawg = rahg From 0b7879cffdbbe71fd7bba4d9e62e154b4cd5afb4 Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Mon, 21 Mar 2022 15:07:58 +0000 Subject: [PATCH 130/217] modify a table of cwp parameter --- physics/module_sf_noahmplsm.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 217f4ce80..e610cc214 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4672,18 +4672,18 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in if (mozg < 0.) then fhgnew = (1. - 15.*mozg)**(-0.25) - fhgnewh = 0.74 * (1. - 9.*mozg)**(-0.5) ! PHIh + fhgnewh = 0.74 * (1. - 9.*mozg)**(-0.5) ! PHIh else fhgnew = 1.+ 4.7*mozg - fhgnewh = 0.74 + 4.7*mozgh ! PHIh + fhgnewh = 0.74 + 4.7*mozgh ! PHIh endif if (iter == 1) then fhg = fhgnew - fhgh = fhgnewh + fhgh = fhgnewh else fhg = 0.5 * (fhg+fhgnew) - fhgh = 0.5 * (fhgh+fhgnewh) + fhgh = 0.5 * (fhgh+fhgnewh) endif cwpc = (cwp * vai * hcan * fhg)**0.5 From 109dcdfaf05e7b9b48b43d7545a54e895d67bd8a Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Mon, 21 Mar 2022 16:15:32 +0000 Subject: [PATCH 131/217] modify a table of cwp parameter --- physics/noahmp_tables.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 6666b2f67..2e3e2920e 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -513,7 +513,7 @@ module noahmp_tables data ( cwpvt_table (i),i=1,mvt) / 0.09, 0.335, 0.09, 0.335, 0.145, 0.50, & & 1.00, 0.65, 0.50, 2.50, 0.585, 0.835, & & 0.835, 0.835, 0.09, 0.09, 0.09, 0.335, & - & 0.835, 0.835, 0.09, 0.09, 0.09, 0.335, & + & 0.50, 0.09, 0.00, 0.00, 0.00, 0.00, & & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / From f2d46db71846d668a2b24d8308b78d6b7a820e9d Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 21 Mar 2022 17:26:39 +0000 Subject: [PATCH 132/217] Changed arguments to implied shape. --- physics/radiation_cloud_overlap.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/physics/radiation_cloud_overlap.F90 b/physics/radiation_cloud_overlap.F90 index 30c7804b1..7fa44ec07 100644 --- a/physics/radiation_cloud_overlap.F90 +++ b/physics/radiation_cloud_overlap.F90 @@ -21,10 +21,10 @@ subroutine cmp_dcorr_lgth_hogan(nCol, lat, con_pi, dcorr_lgth) nCol ! Number of horizontal grid-points real(kind_phys), intent(in) :: & con_pi ! Physical constant: Pi - real(kind_phys), dimension(nCol), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & lat ! Latitude ! Outputs - real(kind_phys), dimension(nCol),intent(out) :: & + real(kind_phys), dimension(:),intent(out) :: & dcorr_lgth ! Decorrelation length ! Local variables @@ -52,11 +52,11 @@ subroutine cmp_dcorr_lgth_oreopoulos(nCol, lat, juldat, yearlength, dcorr_lgth) real(kind_phys), intent(in) :: & juldat ! Julian date - real(kind_phys), dimension(nCol), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & lat ! Latitude ! Outputs - real(kind_phys), dimension(nCol),intent(out) :: & + real(kind_phys), dimension(:),intent(out) :: & dcorr_lgth ! Decorrelation length (km) ! Parameters for the Gaussian fits per Eqs. (10) and (11) (See Table 1) @@ -94,15 +94,15 @@ subroutine get_alpha_exper(nCol, nLay, iovr, iovr_exprand, dzlay, & integer, intent(in) :: & iovr, & iovr_exprand - real(kind_phys), dimension(nCol), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & dcorr_lgth ! Decorrelation length (km) - real(kind_phys), dimension(nCol,nLay), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & dzlay ! - real(kind_phys), dimension(nCol,nLay), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & cld_frac ! Outputs - real(kind_phys), dimension(nCol,nLay) :: & + real(kind_phys), dimension(:,:) :: & alpha ! Cloud overlap parameter ! Local variables From ec19fbe8b2f8ffeccd63e1cbcac328b0c78e3bd6 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 21 Mar 2022 23:28:40 +0000 Subject: [PATCH 133/217] Pulled in SW coupling fix for RRTMGP. Share SW_rad_pre between RRTMG and RRTMGP schemes. --- physics/GFS_rrtmgp_sw_post.F90 | 10 ++-- physics/GFS_rrtmgp_sw_post.meta | 32 +++++----- physics/rad_sw_pre.F90 | 59 +++++++++++++++++++ .../{rrtmg_sw_pre.meta => rad_sw_pre.meta} | 4 +- physics/rrtmg_sw_pre.F90 | 59 ------------------- physics/rrtmgp_sw_rte.F90 | 29 +++++---- physics/rrtmgp_sw_rte.meta | 32 +++++----- 7 files changed, 112 insertions(+), 113 deletions(-) create mode 100644 physics/rad_sw_pre.F90 rename physics/{rrtmg_sw_pre.meta => rad_sw_pre.meta} (96%) delete mode 100644 physics/rrtmg_sw_pre.F90 diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 index 377afdadc..fafa162d9 100644 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ b/physics/GFS_rrtmgp_sw_post.F90 @@ -52,7 +52,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky coszdg ! Cosine(SZA), daytime real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & p_lev ! Pressure @ model layer-interfaces (Pa) - real(kind_phys), dimension(sw_gas_props%get_nband(),ncol), intent(in) :: & + real(kind_phys), dimension(ncol), intent(in) :: & sfc_alb_nir_dir, & ! Surface albedo (direct) sfc_alb_nir_dif, & ! Surface albedo (diffuse) sfc_alb_uvvis_dir, & ! Surface albedo (direct) @@ -170,10 +170,10 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky nirdfdi(i) = scmpsw(i)%nirdf visbmdi(i) = scmpsw(i)%visbm visdfdi(i) = scmpsw(i)%visdf - nirbmui(i) = scmpsw(i)%nirbm * sfc_alb_nir_dir(1,i) - nirdfui(i) = scmpsw(i)%nirdf * sfc_alb_nir_dif(1,i) - visbmui(i) = scmpsw(i)%visbm * sfc_alb_uvvis_dir(1,i) - visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(1,i) + nirbmui(i) = scmpsw(i)%nirbm * sfc_alb_nir_dir(i) + nirdfui(i) = scmpsw(i)%nirdf * sfc_alb_nir_dif(i) + visbmui(i) = scmpsw(i)%visbm * sfc_alb_uvvis_dir(i) + visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(i) enddo else ! if_nday_block ! ####################################################################################### diff --git a/physics/GFS_rrtmgp_sw_post.meta b/physics/GFS_rrtmgp_sw_post.meta index 0e93b78e6..7da3b10b0 100644 --- a/physics/GFS_rrtmgp_sw_post.meta +++ b/physics/GFS_rrtmgp_sw_post.meta @@ -112,34 +112,34 @@ kind = kind_phys intent = in [sfc_alb_nir_dir] - standard_name = surface_albedo_nearIR_direct - long_name = near-IR (direct) surface albedo (sfc_alb_nir_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_near_IR_direct + long_name = surface albedo due to near IR direct beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_nir_dif] - standard_name = surface_albedo_nearIR_diffuse - long_name = near-IR (diffuse) surface albedo (sfc_alb_nir_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_near_IR_diffused + long_name = surface albedo due to near IR diffused beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_uvvis_dir] - standard_name = surface_albedo_uvvis_direct - long_name = UVVIS (direct) surface albedo (sfc_alb_uvvis_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_UV_and_VIS_direct + long_name = surface albedo due to UV+VIS direct beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_uvvis_dif] - standard_name = surface_albedo_uvvis_diffuse - long_name = UVVIS (diffuse) surface albedo (sfc_alb_uvvis_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_UV_and_VIS_diffused + long_name = surface albedo due to UV+VIS diffused beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in diff --git a/physics/rad_sw_pre.F90 b/physics/rad_sw_pre.F90 new file mode 100644 index 000000000..8397387b1 --- /dev/null +++ b/physics/rad_sw_pre.F90 @@ -0,0 +1,59 @@ +! ###################################################################################### +!>\file rad_sw_pre.f90 +!! +!! This file gathers the sunlit points for the shortwave radiation schemes. +!! +!> \defgroup rad_sw_pre GFS radiation pre routine. +!! @{ +!! +! ###################################################################################### +module rad_sw_pre +contains + + ! ################################################################################### +!> \section arg_table_rad_sw_pre_run Argument Table +!! \htmlinclude rad_sw_pre_run.html +!! +!! \section rad_sw_pre_run +!! @{ + ! ################################################################################### + subroutine rad_sw_pre_run (im, lsswr, coszen, nday, idxday, errmsg, errflg) + use machine, only: kind_phys + implicit none + + ! Inputs + integer, intent(in) :: im + logical, intent(in) :: lsswr + realkind_phys), dimension(:), intent(in) :: coszen + + ! Outputs + integer, intent(out) :: nday + integer, dimension(:), intent(out) :: idxday + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (lsswr) then + ! Check for daytime points for SW radiation. + nday = 0 + idxday = 0 + do i = 1, IM + if (coszen(i) >= 0.0001) then + nday = nday + 1 + idxday(nday) = i + endif + enddo + else + nday = 0 + idxday = 0 + endif + + end subroutine rad_sw_pre_run +!! @} +end module rad_sw_pre diff --git a/physics/rrtmg_sw_pre.meta b/physics/rad_sw_pre.meta similarity index 96% rename from physics/rrtmg_sw_pre.meta rename to physics/rad_sw_pre.meta index 6a3a4e0a4..ccbdbf74b 100644 --- a/physics/rrtmg_sw_pre.meta +++ b/physics/rad_sw_pre.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = rrtmg_sw_pre + name = rad_sw_pre type = scheme dependencies = iounitdef.f,machine.F ######################################################################## [ccpp-arg-table] - name = rrtmg_sw_pre_run + name = rad_sw_pre_run type = scheme [im] standard_name = horizontal_loop_extent diff --git a/physics/rrtmg_sw_pre.F90 b/physics/rrtmg_sw_pre.F90 deleted file mode 100644 index 1c7d3d76b..000000000 --- a/physics/rrtmg_sw_pre.F90 +++ /dev/null @@ -1,59 +0,0 @@ -!>\file rrtmg_sw_pre.f90 - module rrtmg_sw_pre - contains - -!>\defgroup rrtmg_sw_pre GFS RRTMG scheme Pre -!! @{ - subroutine rrtmg_sw_pre_init () - end subroutine rrtmg_sw_pre_init - -!> \section arg_table_rrtmg_sw_pre_run Argument Table -!! \htmlinclude rrtmg_sw_pre_run.html -!! - subroutine rrtmg_sw_pre_run (im, lsswr, coszen, nday, idxday, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: im - logical, intent(in) :: lsswr - real(kind=kind_phys), dimension(:), intent(in) :: coszen - integer, intent(out) :: nday - integer, dimension(:), intent(out) :: idxday - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! --- ... start radiation calculations -! remember to set heating rate unit to k/sec! - -!> -# Start SW radiation calculations - if (lsswr) then -!> - Check for daytime points for SW radiation. - nday = 0 - idxday = 0 - do i = 1, IM - if (coszen(i) >= 0.0001) then - nday = nday + 1 - idxday(nday) = i - endif - enddo - else - nday = 0 - idxday = 0 - endif - - end subroutine rrtmg_sw_pre_run - - subroutine rrtmg_sw_pre_finalize () - end subroutine rrtmg_sw_pre_finalize - -!! @} - end module rrtmg_sw_pre diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index cbbdb1c4f..e1879bd7a 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -31,7 +31,7 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz sw_optical_props_cnvcloudsByBand, sw_optical_props_MYNNcloudsByBand, & sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, & fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) - + ! Inputs logical, intent(in) :: & top_at_1, & ! Vertical ordering flag @@ -47,24 +47,23 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz integer, intent(in), dimension(:) :: & idxday ! Index array for daytime points real(kind_phys),intent(in), dimension(:) :: & + sfc_alb_nir_dir, & ! Surface albedo (direct) + sfc_alb_nir_dif, & ! Surface albedo (diffuse) + sfc_alb_uvvis_dir, & ! Surface albedo (direct) + sfc_alb_uvvis_dif, & ! Surface albedo (diffuse) coszen ! Cosize of SZA real(kind_phys), dimension(:,:), intent(in) :: & p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay ! Temperature (K) + t_lay, & ! Temperature (K) + toa_src_sw ! TOA incident spectral flux (W/m2) type(ty_optical_props_2str),intent(inout) :: & sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties - type(ty_optical_props_2str),intent(in) :: & + type(ty_optical_props_2str),intent(in) :: & sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud optical properties sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: shortwave convecive cloud optical properties sw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: shortwave MYNN-EDMF PBL cloud optical properties sw_optical_props_precipByBand, & ! RRTMGP DDT: shortwave precipitation optical properties sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol optical properties - real(kind_phys), dimension(:,:), intent(in) :: & - sfc_alb_nir_dir, & ! Surface albedo (direct) - sfc_alb_nir_dif, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir, & ! Surface albedo (direct) - sfc_alb_uvvis_dif, & ! Surface albedo (diffuse) - toa_src_sw ! TOA incident spectral flux (W/m2) ! Outputs character(len=*), intent(out) :: & @@ -119,17 +118,17 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz bandlimits = sw_gas_props%get_band_lims_wavenumber() do iBand=1,sw_gas_props%get_nband() if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,:) = sfc_alb_nir_dir(iBand,idxday(1:nday)) - sfc_alb_dif(iBand,:) = sfc_alb_nir_dif(iBand,idxday(1:nday)) + sfc_alb_dir(iBand,:) = sfc_alb_nir_dir(idxday(1:nday)) + sfc_alb_dif(iBand,:) = sfc_alb_nir_dif(idxday(1:nday)) endif if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dir(iBand,idxday(1:nday)) + sfc_alb_uvvis_dir(iBand,idxday(1:nday))) - sfc_alb_dif(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dif(iBand,idxday(1:nday)) + sfc_alb_uvvis_dif(iBand,idxday(1:nday))) + sfc_alb_dir(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dir(idxday(1:nday)) + sfc_alb_uvvis_dir(idxday(1:nday))) + sfc_alb_dif(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dif(idxday(1:nday)) + sfc_alb_uvvis_dif(idxday(1:nday))) ibd = iBand endif if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then - sfc_alb_dir(iBand,:) = sfc_alb_uvvis_dir(iBand,idxday(1:nday)) - sfc_alb_dif(iBand,:) = sfc_alb_uvvis_dif(iBand,idxday(1:nday)) + sfc_alb_dir(iBand,:) = sfc_alb_uvvis_dir(idxday(1:nday)) + sfc_alb_dif(iBand,:) = sfc_alb_uvvis_dif(idxday(1:nday)) endif enddo diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index d89d0d966..9ab24c8b3 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -145,34 +145,34 @@ type = ty_optical_props_2str intent = in [sfc_alb_nir_dir] - standard_name = surface_albedo_nearIR_direct - long_name = near-IR (direct) surface albedo (sfc_alb_nir_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_near_IR_direct + long_name = surface albedo due to near IR direct beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_nir_dif] - standard_name = surface_albedo_nearIR_diffuse - long_name = near-IR (diffuse) surface albedo (sfc_alb_nir_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_near_IR_diffused + long_name = surface albedo due to near IR diffused beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_uvvis_dir] - standard_name = surface_albedo_uvvis_direct - long_name = UVVIS (direct) surface albedo (sfc_alb_uvvis_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_UV_and_VIS_direct + long_name = surface albedo due to UV+VIS direct beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_uvvis_dif] - standard_name = surface_albedo_uvvis_diffuse - long_name = UVVIS (diffuse) surface albedo (sfc_alb_uvvis_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_UV_and_VIS_diffused + long_name = surface albedo due to UV+VIS diffused beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in From 942510fa63a9f4a21905acb4d295f19e83d42953 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Tue, 22 Mar 2022 14:20:12 +0000 Subject: [PATCH 134/217] removing added cloud fraction in precipitation for MYNN --- physics/GFS_rrtmg_pre.F90 | 17 +---------------- physics/GFS_rrtmgp_gfdlmp_pre.F90 | 11 ++--------- 2 files changed, 3 insertions(+), 25 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 15845d4b3..db818c3b8 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -744,21 +744,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo endif elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP - if ((imfdeepcnv==imfdeepcnv_gf .or. do_mynnedmf) .and. kdt>1) then - if (do_mynnedmf) then - do k=1,lm - k1 = k + kd - do i=1,im - if (tracer1(i,k1,ntrw)>1.0e-7 .OR. tracer1(i,k1,ntsw)>1.0e-7) then - ! GFDL cloud fraction - cldcov(i,k1) = tracer1(i,k1,ntclamt) - else - ! MYNN sub-grid cloud fraction - cldcov(i,k1) = clouds1(i,k1) - endif - enddo - enddo - else ! imfdeepcnv==imfdeepcnv_gf + if ((imfdeepcnv==imfdeepcnv_gf) .and. kdt>1) then do k=1,lm k1 = k + kd do i=1,im @@ -770,7 +756,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif enddo enddo - endif else ! GFDL cloud fraction cldcov(1:IM,1+kd:LM+kd) = tracer1(1:IM,1:LM,ntclamt) diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 index c6afd6ac0..d9d7c37f6 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.F90 +++ b/physics/GFS_rrtmgp_gfdlmp_pre.F90 @@ -165,16 +165,9 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld where(cld_reice .gt. radice_upr) cld_reice = radice_upr endif - ! Cloud-fraction. For mynnedmf, cld_frac is adjusted for precipitation here, otherwise - ! it passes through this interface. It is adjusted prior in sgscloudradpre. + ! Cloud-fraction. For mynnedmf, cld_frac is already defined in sgscloudradpre. if (do_mynnedmf .and. kdt .gt. 1) then - do iLay = 1, nLev - do iCol = 1, nCol - if (tracer(iCol,iLay,i_cldrain) > 1.0e-7 .OR. tracer(iCol,iLay,i_cldsnow)>1.0e-7) then - cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) - endif - enddo - enddo + !already set in sgscloudradpre else cld_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) endif From 6176537497f70f19e691e706b6370aa2bb31a2df Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Tue, 22 Mar 2022 14:24:41 +0000 Subject: [PATCH 135/217] updating MYNN-EDMF SGS clouds and tweaks to the lateral entrainment in the MF scheme. --- physics/module_MYNNPBL_wrapper.F90 | 74 ++-- physics/module_MYNNPBL_wrapper.meta | 8 + physics/module_bl_mynn.F90 | 501 +++++++++++----------------- 3 files changed, 244 insertions(+), 339 deletions(-) diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 9d720b9f8..d9e53f9d3 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -132,7 +132,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dtsfc_cpl,dqsfc_cpl, & & recmol, & & qke,qke_adv,Tsq,Qsq,Cov, & - & el_pbl,sh3d,exch_h,exch_m, & + & el_pbl,sh3d,sm3d,exch_h,exch_m, & & dqke,qwt,qshear,qbuoy,qdiss, & & Pblh,kpbl, & & qc_bl,qi_bl,cldfra_bl, & @@ -179,10 +179,10 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, intent(in) :: cplflx !smoke/chem - !logical, intent(in) :: rrfs_smoke, rrfs_smoke, fire_turb + !logical, intent(in) :: mix_chem, fire_turb !integer, intent(in) :: nchem, ndvel, kdvel !for testing only: - logical, parameter :: rrfs_smoke=.false., mix_chem=.false., fire_turb=.false. + logical, parameter :: mix_chem=.false., fire_turb=.false. integer, parameter :: nchem=2, ndvel=2, kdvel=1 ! NAMELIST OPTIONS (INPUT): @@ -248,7 +248,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_ozone, dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc real(kind=kind_phys), dimension(:,:), intent(inout) :: & - & qke, qke_adv, EL_PBL, Sh3D, & + & qke, qke_adv, EL_PBL, Sh3D, Sm3D, & & qc_bl, qi_bl, cldfra_bl !These 10 arrays are only allocated when bl_mynn_output > 0 real(kind=kind_phys), dimension(:,:), intent(inout) :: & @@ -366,7 +366,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FRP = 0. EMIS_ANT_NO = 0. vdep = 0. ! hli for chem dry deposition, 0 temporarily - if (rrfs_smoke) then + if (mix_chem) then allocate ( chem3d(im,levs,nchem) ) do k=1,levs do i=1,im @@ -697,11 +697,10 @@ SUBROUTINE mynnedmf_wrapper_run( & & ust=ust,ch=ch,hfx=hfx,qfx=qfx,rmol=rmol, & & wspd=wspd,uoce=uoce,voce=voce,vdfg=vdfg, & !input & qke=QKE,qke_adv=qke_adv, & !output - & bl_mynn_tkeadvect=bl_mynn_tkeadvect,sh3d=Sh3d, & + & sh3d=Sh3d,sm3d=Sm3d, & !chem/smoke & nchem=nchem,kdvel=kdvel,ndvel=ndvel, & & Chem3d=chem3d,Vdep=vdep, & - & rrfs_smoke=rrfs_smoke, & & FRP=frp,EMIS_ANT_NO=emis_ant_no, & & mix_chem=mix_chem,fire_turb=fire_turb, & !----- @@ -712,36 +711,37 @@ SUBROUTINE mynnedmf_wrapper_run( & & RQNIBLTEN=rqniblten,RQNWFABLTEN=RQNWFABLTEN, & !output & RQNIFABLTEN=RQNIFABLTEN,dozone=dqdt_ozone, & !output & EXCH_H=exch_h,EXCH_M=exch_m, & !output - & pblh=pblh,KPBL=KPBL & !output - & ,el_pbl=el_pbl & !output - & ,dqke=dqke & !output - & ,qWT=qWT,qSHEAR=qSHEAR,qBUOY=qBUOY,qDISS=qDISS & !output - & ,bl_mynn_tkebudget=bl_mynn_tkebudget & !input parameter - & ,bl_mynn_cloudpdf=bl_mynn_cloudpdf & !input parameter - & ,bl_mynn_mixlength=bl_mynn_mixlength & !input parameter - & ,icloud_bl=icloud_bl & !input parameter - & ,qc_bl=qc_bl,qi_bl=qi_bl,cldfra_bl=cldfra_bl & !output - & ,closure=bl_mynn_closure,bl_mynn_edmf=bl_mynn_edmf & !input parameter - & ,bl_mynn_edmf_mom=bl_mynn_edmf_mom & !input parameter - & ,bl_mynn_edmf_tke=bl_mynn_edmf_tke & !input parameter - & ,bl_mynn_mixscalars=bl_mynn_mixscalars & !input parameter - & ,bl_mynn_output=bl_mynn_output & !input parameter - & ,bl_mynn_cloudmix=bl_mynn_cloudmix & !input parameter - & ,bl_mynn_mixqt=bl_mynn_mixqt & !input parameter - & ,edmf_a=edmf_a,edmf_w=edmf_w,edmf_qt=edmf_qt & !output - & ,edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc &!output - & ,sub_thl3D=sub_thl,sub_sqv3D=sub_sqv & - & ,det_thl3D=det_thl,det_sqv3D=det_sqv & - & ,nupdraft=nupdraft,maxMF=maxMF & !output - & ,ktop_plume=ktop_plume & !output - & ,spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl & !input - & ,RTHRATEN=htrlw & !input - & ,FLAG_QI=flag_qi,FLAG_QNI=flag_qni & !input - & ,FLAG_QC=flag_qc,FLAG_QNC=flag_qnc & !input - & ,FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA & !input - & ,IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs & !input - & ,IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs & !input - & ,ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs) !input + & pblh=pblh,KPBL=KPBL, & !output + & el_pbl=el_pbl, & !output + & dqke=dqke, & !output + & qWT=qWT,qSHEAR=qSHEAR,qBUOY=qBUOY,qDISS=qDISS, & !output + & bl_mynn_tkeadvect=bl_mynn_tkeadvect, & + & bl_mynn_tkebudget=bl_mynn_tkebudget, & !input parameter + & bl_mynn_cloudpdf=bl_mynn_cloudpdf, & !input parameter + & bl_mynn_mixlength=bl_mynn_mixlength, & !input parameter + & icloud_bl=icloud_bl, & !input parameter + & qc_bl=qc_bl,qi_bl=qi_bl,cldfra_bl=cldfra_bl, & !output + & closure=bl_mynn_closure,bl_mynn_edmf=bl_mynn_edmf, & !input parameter + & bl_mynn_edmf_mom=bl_mynn_edmf_mom, & !input parameter + & bl_mynn_edmf_tke=bl_mynn_edmf_tke, & !input parameter + & bl_mynn_mixscalars=bl_mynn_mixscalars, & !input parameter + & bl_mynn_output=bl_mynn_output, & !input parameter + & bl_mynn_cloudmix=bl_mynn_cloudmix, & !input parameter + & bl_mynn_mixqt=bl_mynn_mixqt, & !input parameter + & edmf_a=edmf_a,edmf_w=edmf_w,edmf_qt=edmf_qt, & !output + & edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc,&!output + & sub_thl3D=sub_thl,sub_sqv3D=sub_sqv, & + & det_thl3D=det_thl,det_sqv3D=det_sqv, & + & nupdraft=nupdraft,maxMF=maxMF, & !output + & ktop_plume=ktop_plume, & !output + & spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl, & !input + & RTHRATEN=htrlw, & !input + & FLAG_QI=flag_qi,FLAG_QNI=flag_qni, & !input + & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc, & !input + & FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA, & !input + & IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs, & !input + & IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs, & !input + & ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs) !input ! POST MYNN (INTERSTITIAL) WORK: diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 60668ba88..658c80100 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -764,6 +764,14 @@ type = real kind = kind_phys intent = inout +[Sm3D] + standard_name = stability_function_for_momentum + long_name = stability function for momentum + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [exch_h] standard_name = atmosphere_heat_diffusivity_for_mynnpbl long_name = diffusivity for heat for MYNN PBL (defined for all mass levels) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 36ff3ebf7..292d5aa18 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -216,7 +216,7 @@ ! Misc small-impact bugfixes: ! 1) dz was incorrectly indexed in mym_condensation ! 2) configurations with icloud_bl = 0 were using uninitialized arrays -! v4.3.2 / CCPP +! v4.4 / CCPP ! This version includes many modifications that proved valuable in the global ! framework and removes some key lingering bugs in the mixing of chemical species. ! TKE Budget output fixed (Puhales, 2020-12) @@ -228,9 +228,8 @@ ! Important bug fixes for mixing of chemical species. ! Addition of pressure-gradient effects on updraft momentum transport. ! Addition of bl_mynn_closure option = 2.5, 2.6, or 3.0 -! Addition of sig_order to regulate the use of higher-order moments -! for sigma when using bl_mynn_cloudpdf = 2 (Chab-Becht). This -! new option is set in the subroutine mym_condensation. +! Addition of higher-order moments for sigma when using +! bl_mynn_cloudpdf = 2 (Chab-Becht). ! Removed WRF_CHEM dependencies. ! Many miscellaneous tweaks. ! @@ -322,7 +321,7 @@ MODULE module_bl_mynn IMPLICIT NONE - +!get rid INTEGER , PARAMETER :: param_first_scalar = 1, & & p_qc = 2, & & p_qr = 0, & @@ -332,23 +331,8 @@ MODULE module_bl_mynn & p_qnc= 0, & & p_qni= 0 -!END FV3 CONSTANTS -!==================================================================== -!WRF CONSTANTS -! USE module_model_constants, only: & -! &karman, grav, p1000mb, & -! &cp, r_d, r_v, rcp, xlv, xlf, xls, & -! &svp1, svp2, svp3, p608, ep_2, rvovrd, & -! &cpv, cliq, cice -! -! USE module_state_description, only: param_first_scalar, & -! &p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni -! -! IMPLICIT NONE -! -!END WRF CONSTANTS !=================================================================== -! From here on, these are used for any model +! From here on, these are MYNN-specific parameters: ! The parameters below depend on stability functions of module_sf_mynn. REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & cphh_st=5.0, cphh_unst=16.0 @@ -476,11 +460,10 @@ SUBROUTINE mynn_bl_driver( & &uoce,voce, & !ocean current &vdfg, & !Katata-added for fog dep &Qke,qke_adv, & - &bl_mynn_tkeadvect,sh3d, & + &sh3d,sm3d, & &nchem,kdvel,ndvel, & !Smoke/Chem variables &chem3d, vdep, & - &rrfs_smoke, & ! flag for Smoke &frp,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs &mix_chem,fire_turb, & ! end smoke/chem variables @@ -488,15 +471,18 @@ SUBROUTINE mynn_bl_driver( & &RUBLTEN,RVBLTEN,RTHBLTEN, & &RQVBLTEN,RQCBLTEN,RQIBLTEN, & &RQNCBLTEN,RQNIBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN,DOZONE, & + &RQNWFABLTEN,RQNIFABLTEN, & + &DOZONE, & &exch_h,exch_m, & &Pblh,kpbl, & &el_pbl, & - &dqke,qWT,qSHEAR,qBUOY,qDISS, & !TKE BUDGET + &dqke,qWT,qSHEAR,qBUOY,qDISS, & + &qc_bl,qi_bl,cldfra_bl, & + &bl_mynn_tkeadvect, & &bl_mynn_tkebudget, & &bl_mynn_cloudpdf, & &bl_mynn_mixlength, & - &icloud_bl,qc_bl,qi_bl,cldfra_bl,& + &icloud_bl, & &closure, & &bl_mynn_edmf, & &bl_mynn_edmf_mom, & @@ -541,7 +527,7 @@ SUBROUTINE mynn_bl_driver( & LOGICAL, INTENT(IN) :: mix_chem,fire_turb - INTEGER,INTENT(in) :: & + INTEGER, INTENT(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & &,IMS,IME,JMS,JME,KMS,KME & &,ITS,ITE,JTS,JTE,KTS,KTE @@ -558,37 +544,32 @@ SUBROUTINE mynn_bl_driver( & ! = 3; Level 3 REAL, INTENT(in) :: delt -!WRF -! REAL, INTENT(in) :: dx -!END WRF -!FV3 REAL, DIMENSION(IMS:IME), INTENT(in) :: dx -!END FV3 - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz,& + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in)::& + REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: & &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: ozone - REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust,& + REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust, & &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &Qke,Tsq,Qsq,Cov,qke_adv !ACF for QKE advection + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + &Qke,Tsq,Qsq,Cov,qke_adv - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& - &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN, & + &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & &RQNWFABLTEN,RQNIFABLTEN REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: DOZONE - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & &exch_h,exch_m !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL, DIMENSION(:,:), OPTIONAL, INTENT(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & + REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(inout) :: & + & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D ! REAL, DIMENSION(IMS:IME,KMS:KME) :: & @@ -607,13 +588,13 @@ SUBROUTINE mynn_bl_driver( & REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & &el_pbl - REAL, DIMENSION(:,:), INTENT(out) :: & + REAL, DIMENSION(IMS:IME,KMS:KME), optional, INTENT(out) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when bl_mynn_tkebudget == .false. ! 1D (local) budget arrays are used for passing between subroutines. - REAL, DIMENSION(KTS:KTE) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat + REAL, DIMENSION(kts:kte) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat - REAL, DIMENSION(IMS:IME,KMS:KME) :: Sh3D + REAL, DIMENSION(IMS:IME,KMS:KME), intent(out) :: Sh3D,Sm3D REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl @@ -622,40 +603,42 @@ SUBROUTINE mynn_bl_driver( & ! smoke/chemical arrays INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel - LOGICAL, OPTIONAL, INTENT(IN ) :: rrfs_smoke ! REAL, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), optional :: chem3d ! REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), optional :: vdep - REAL, DIMENSION( :,:,: ), INTENT(INOUT), optional :: chem3d - REAL, DIMENSION( :,: ), INTENT(IN), optional :: vdep - REAL, DIMENSION( : ), INTENT(IN), optional :: frp,EMIS_ANT_NO - - REAL, DIMENSION(KTS:KTE ,nchem) :: chem1 - REAL, DIMENSION(KTS:KTE+1,nchem) :: s_awchem1 - REAL, DIMENSION(its:ite) :: vd1 + REAL, DIMENSION(ims:ime, kms:kme, nchem), INTENT(INOUT), optional :: chem3d + REAL, DIMENSION(ims:ime, ndvel), INTENT(IN), optional :: vdep + REAL, DIMENSION(ims:ime), INTENT(IN), optional :: frp,EMIS_ANT_NO + !local + REAL, DIMENSION(kts:kte ,nchem) :: chem1 + REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 + REAL, DIMENSION(ndvel) :: vd1 INTEGER :: ic !local vars INTEGER :: ITF,JTF,KTF, IMD,JMD INTEGER :: i,j,k REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw,& - &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & + &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & &Vt, Vq, sgm, thlsg, sqwsg - REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,& - &qke1,tsq1,qsq1,cov1,sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & - &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1,dqnwfa1,dqnifa1,dozone1 + REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1, & + &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & + &sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & + &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & + &dqnwfa1,dqnifa1,dozone1 !mass-flux variables REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,& - edmf_ent1,edmf_qc1 - REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1,& - edmf_ent_dd1,edmf_qc_dd1 - REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & + REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1, & + &edmf_thl1,edmf_ent1,edmf_qc1 + REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1, & + &edmf_qt_dd1,edmf_thl_dd1, & + &edmf_ent_dd1,edmf_qc_dd1 + REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v,& det_thl,det_sqv,det_sqc,det_u,det_v - REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1,& - s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1,& + REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1, & + s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1 - REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1,& + REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, & sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 REAL, DIMENSION(KTS:KTE+1) :: zw @@ -670,10 +653,9 @@ SUBROUTINE mynn_bl_driver( & LOGICAL :: INITIALIZE_QKE ! Stochastic fields - INTEGER, INTENT(IN) :: spp_pbl - !GJF: this array must be assumed-shape since it's conditionally-allocated - REAL, DIMENSION(:,:), INTENT(IN) :: pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col + INTEGER, INTENT(IN) ::spp_pbl + REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl + REAL, DIMENSION(KTS:KTE) ::rstoch_col ! Substepping TKE INTEGER :: nsub @@ -702,11 +684,6 @@ SUBROUTINE mynn_bl_driver( & JMD=(JMS+JME)/2 !*** End debugging -!WRF -! JTF=MIN0(JTE,JDE-1) -! ITF=MIN0(ITE,IDE-1) -! KTF=MIN0(KTE,KDE-1) -!FV3 JTF=JTE ITF=ITE KTF=KTE @@ -758,6 +735,7 @@ SUBROUTINE mynn_bl_driver( & if (.not.restart .or. .not.cycling) THEN Sh3D(its:ite,kts:kte)=0. + Sm3D(its:ite,kts:kte)=0. el_pbl(its:ite,kts:kte)=0. tsq(its:ite,kts:kte)=0. qsq(its:ite,kts:kte)=0. @@ -882,6 +860,7 @@ SUBROUTINE mynn_bl_driver( & ENDIF el(k)=el_pbl(i,k) sh(k)=Sh3D(i,k) + sm(k)=Sm3D(i,k) tsq1(k)=tsq(i,k) qsq1(k)=qsq(i,k) cov1(k)=cov(i,k) @@ -933,6 +912,7 @@ SUBROUTINE mynn_bl_driver( & DO k=KTS,KTE !KTF el_pbl(i,k)=el(k) sh3d(i,k)=sh(k) + sm3d(i,k)=sm(k) qke(i,k)=qke1(k) tsq(i,k)=tsq1(k) qsq(i,k)=qsq1(k) @@ -1078,7 +1058,8 @@ SUBROUTINE mynn_bl_driver( & ENDIF el(k) = el_pbl(i,k) qke1(k)=qke(i,k) - sh(k) = sh3d(i,k) + sh(k) =sh3d(i,k) + sm(k) =sm3d(i,k) tsq1(k)=tsq(i,k) qsq1(k)=qsq(i,k) cov1(k)=cov(i,k) @@ -1134,7 +1115,6 @@ SUBROUTINE mynn_bl_driver( & ENDDO ! end k !initialize smoke/chem arrays (if used): - IF (rrfs_smoke .or. mix_chem) then IF (mix_chem ) then do ic = 1,ndvel vd1(ic) = vdep(i,ic) !is this correct???? @@ -1160,7 +1140,6 @@ SUBROUTINE mynn_bl_driver( & enddo enddo ENDIF - ENDIF zw(kte+1)=zw(kte)+dz(i,kte) !EDMF @@ -1383,8 +1362,9 @@ SUBROUTINE mynn_bl_driver( & if (dheat_opt > 0) then DO k=kts,kte-1 ! Set max dissipative heating rate to 7.2 K per hour - diss_heat(k) = MIN(MAX(0.75*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) - diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) + diss_heat(k) = MIN(MAX(1.0*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) + ! Limit heating above 100 mb: + diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) ENDDO diss_heat(kte) = 0. else @@ -1517,7 +1497,7 @@ SUBROUTINE mynn_bl_driver( & qsq(i,k)=qsq1(k) cov(i,k)=cov1(k) sh3d(i,k)=sh(k) - + sm3d(i,k)=sm(k) ENDDO !end-k IF ( bl_mynn_tkebudget ) THEN @@ -2108,11 +2088,11 @@ SUBROUTINE mym_length ( & CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac cns = 2.7 - alp1 = 0.23 + alp1 = 0.21 alp2 = 1.0 alp3 = 5.0 alp4 = 100. - alp5 = 0.2 + alp5 = 0.3 ! Impose limits on the height integration for elt and the transition layer depth zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km. @@ -2194,7 +2174,7 @@ SUBROUTINE mym_length ( & alp2 = 0.3 alp3 = 1.5 alp4 = 5.0 - alp5 = 0.2 + alp5 = 0.3 alp6 = 50. ! Impose limits on the height integration for elt and the transition layer depth @@ -2246,6 +2226,7 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN + alp2 = 0.3 + 0.15*0.5*(cldfra_bl1D(k)+cldfra_bl1D(k-1)) bv = SQRT( gtr*dtv(k) ) !elb = alp2*qkw(k) / bv & ! formulation, ! & *( 1.0 + alp3/alp2*& ! except keep @@ -2876,7 +2857,7 @@ SUBROUTINE mym_turbulence ( & REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2,& gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min,& - sm_pbl,sh_pbl,zi2,wt + sm_pbl,sh_pbl,zi2,wt,slht,wtpr DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv @@ -2885,7 +2866,7 @@ SUBROUTINE mym_turbulence ( & ! Stochastic INTEGER, INTENT(IN) :: spp_pbl REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: Prnum + REAL :: Prnum, Prlim REAL, PARAMETER :: Prlimit = 5.0 @@ -2972,11 +2953,10 @@ SUBROUTINE mym_turbulence ( & ! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** -!JOE-test new stability criteria in level 2.5 (as well as level 3) - little/no impact +! new stability criteria in level 2.5 (as well as level 3) - little/no impact ! ** Limitation on q, instead of L/q ** - dlsq = elsq - IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) -!JOE-end + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) IF ( q3sq .LT. q2sq ) THEN !Apply Helfand & Labraga mod @@ -3084,6 +3064,9 @@ SUBROUTINE mym_turbulence ( & !IF ( sm(k) > sm25max ) sm(k) = sm25max !IF ( sm(k) < sm25min ) sm(k) = sm25min !sm(k) = Prnum*sh(k) + slht = zi*0.1 + wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer + Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit sm(k) = MIN(sm(k), Prlimit*Sh(k)) ! ** Level 3 : start ** @@ -3236,10 +3219,9 @@ SUBROUTINE mym_turbulence ( & END IF ! ! Add min background stability function (diffusivity) within model levels -! with active plumes and low cloud fractions. +! with active plumes and clouds. cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN - cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & @@ -3249,8 +3231,8 @@ SUBROUTINE mym_turbulence ( & sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) ! for clouds - sm(k) = MAX(sm(k), 0.03*MIN(cldavg,1.0) ) - sh(k) = MAX(sh(k), 0.03*MIN(cldavg,1.0) ) + sm(k) = MAX(sm(k), 0.05*MIN(cldavg,1.0) ) + sh(k) = MAX(sh(k), 0.05*MIN(cldavg,1.0) ) ENDIF ! elq = el(k)*qkw(k) @@ -3625,7 +3607,7 @@ SUBROUTINE mym_predict (kts,kte, & DO k=kts,kte !qsq(k)=d(k-kts+1) - qsq(k)=MAX(x(k),1e-12) + qsq(k)=MAX(x(k),1e-17) ENDDO ELSE !level 2.5 - use level 2 diagnostic @@ -3781,8 +3763,8 @@ END SUBROUTINE mym_predict ! Output variables: see subroutine mym_initialize ! cld(nx,nz,ny) : Cloud fraction ! -! Work arrays: -! qmq(nx,nz,ny) : Q_w-Q_{sl}, where Q_{sl} is the saturation +! Work arrays/variables: +! qmq : Q_w-Q_{sl}, where Q_{sl} is the saturation ! specific humidity at T=Tl ! alp(nx,nz,ny) : Functions in the condensation process ! bet(nx,nz,ny) : ditto @@ -3830,15 +3812,15 @@ SUBROUTINE mym_condensation (kts,kte, & REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm - REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,ql,q1,RH + REAL, DIMENSION(kts:kte) :: alp,a,bet,b,ql,q1,RH REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, & cldfra_bl1D DOUBLE PRECISION :: t3sq, r3sq, c3sq - REAL :: qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,qlk,eq1,qll,& - &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,Fng,qww,alpha,beta,bb,& - &ls_min,ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& - &low_weight + REAL :: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll,& + &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb,& + &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& + &qmq,qsat_tk INTEGER :: i,j,k REAL :: erf @@ -3850,7 +3832,6 @@ SUBROUTINE mym_condensation (kts,kte, & !variables for SGS BL clouds REAL :: zagl,damp,PBLH2 REAL :: lfac - INTEGER, PARAMETER :: sig_order = 2 !sigma form, 1: use state variables, 2: higher-order variables !JAYMES: variables for tropopause-height estimation REAL :: theta1, theta2, ht1, ht2 @@ -3917,11 +3898,11 @@ SUBROUTINE mym_condensation (kts,kte, & c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq !DEFICIT/EXCESS WATER CONTENT - qmq(k) = qw(k) -qsl + qmq = qw(k) -qsl !ORIGINAL STANDARD DEVIATION sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) !NORMALIZED DEPARTURE FROM SATURATION - q1(k) = qmq(k) / sgm(k) + q1(k) = qmq / sgm(k) !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 cldfra_bl1D(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) @@ -3979,8 +3960,8 @@ SUBROUTINE mym_condensation (kts,kte, & sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & b2 * MAX(Sh(k),0.03))/4. * & (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) - qmq(k) = qw(k) -qsl - q1(k) = qmq(k) / sgm(k) + qmq = qw(k) -qsl + q1(k) = qmq / sgm(k) cldfra_bl1D(K) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) !now compute estimated lwc for PBL scheme's use @@ -4016,144 +3997,54 @@ SUBROUTINE mym_condensation (kts,kte, & CASE (2, -2) - if (sig_order == 1) then - !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS - !using the first-order version of sigma (their eq. 5). - !JAYMES- this added 27 Apr 2015 - PBLH2=MAX(10.,PBLH1) - zagl = 0. - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*xlv/( r_d*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - xl = xl_blend(t) ! obtain latent heat - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl - ! CB02, Eqn. 4 - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - !SPP - qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - !qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; - ! the numerator of Q1 - qmq(k) = a(k) * (qw_pert - qsat_tl) - b(k) = a(k)*rsl ! CB02 variable "b" + !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS + !but with use of higher-order moments to estimate sigma + PBLH2=MAX(10.,PBLH1) + zagl = 0. + DO k = kts,kte-1 + zagl = zagl + dz(k) + t = th(k)*exner(k) + + xl = xl_blend(t) ! obtain latent heat + qsat_tk = qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p + rh(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsat_tk)),0.001) + + !dqw/dT: Clausius-Clapeyron + dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) - dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & - & - 0.5*(tlk + thl(MAX(k-1,kts))*(p(MAX(k-1,kts))/p1000mb)**rcp) - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature) + ! CB02, Eqn. 4 + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + b(k) = a(k)*rsl ! CB02 variable "b" - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = dz(k) - end if + !SPP + qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - cdhdz = dtl/dzk + (grav/cpm)*(1.+qw(k)) ! expression below Eq. 9 - ! in CB02 - zagl = zagl + dz(k) - !Use analog to surface layer length scale to make the cloud mixing length scale - !become less than z in stable conditions. - els = zagl !save for more testing: /(1.0 + 1.0*MIN( 0.5*dz(1)*MAX(rmo,0.0), 1. )) - - !ls_min = 300. + MIN(3.*MAX(HFX1,0.),300.) - ls_min = 300. + MIN(2.*MAX(HFX1,0.),150.) - ls_min = MIN(MAX(els,25.),ls_min) ! Let this be the minimum possible length scale: - if (zagl > PBLH1+2000.) ls_min = MAX(ls_min + 0.5*(PBLH1+2000.-zagl),300.) - ! 25 m < ls_min(=zagl) < 300 m - lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: - ! lfac(750 m) = 4.4 - ! lfac(3 km) = 5.0 - ! lfac(13 km) = 6.0 - ls = MAX(MIN(lfac*el(k),600.),ls_min) ! Bounded: ls_min < ls < 600 m - ! Note: CB02 use 900 m as a constant free-atmosphere length scale. - - ! Above 300 m AGL, ls_min remains 300 m. For dx = 3 km, the - ! MYNN master length scale (el) must exceed 60 m before ls - ! becomes responsive to el, otherwise ls = ls_min = 300 m. - - sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: - & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, - & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, - & +b(k)**2 * cdhdz**2))) ! < 3rd term - ! CB02 use a multiplier of 0.2, but 0.225 is chosen - ! based on tests - - q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation - cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - END DO + !This form of qmq (the numerator of Q1) no longer uses the a(k) factor + qmq = qw_pert - qsat_tk ! saturation deficit/excess; - else + !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) + !except neglect all but the first term for sig_r + r3sq = MAX( qsq(k), 0.0 ) + !Calculate sigma using higher-order moments: + sgm(k) = SQRT( r3sq ) + !Set limits on sigma relative to saturation water vapor + sgm(k) = MIN( sgm(k), qsat_tk*0.666 ) !500 ) + sgm(k) = MAX( sgm(k), qsat_tk*0.040 ) !Note: 0.02 results in SWDOWN similar + !to the first-order version of sigma + q1(k) = qmq / sgm(k) ! Q1, the normalized saturation + + !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 + cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 + !This form only allows cloud fractions out to q1 = -1.8 + !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.41*ATAN(1.55*q1(k)))) + !This form only allows cloud fractions out to q1 = -1 + !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.50*ATAN(1.55*q1(k)))) - !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS - !but with use of higher-order moments to estimate sigma - PBLH2=MAX(10.,PBLH1) - zagl = 0. - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*xlv/( r_d*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - xl = xl_blend(t) ! obtain latent heat - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl - ! CB02, Eqn. 4 - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - b(k) = a(k)*rsl ! CB02 variable "b" - - !SPP - qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - - !This form of qmq (the numerator of Q1) no longer uses the a(k) factor - qmq(k) = qw_pert - qsat_tl ! saturation deficit/excess; - - !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) - !except neglect all but the first term for sig_r - r3sq = MAX( qsq(k), 0.0 ) - !Calculate sigma using higher-order moments: - sgm(k) = SQRT( r3sq ) - !Set limits on sigma relative to saturation water vapor - sgm(k) = MIN( sgm(k), qsat_tl*0.666 ) !500 ) - sgm(k) = MAX( sgm(k), qsat_tl*0.050 ) !Note: 0.02 results in SWDOWN similar - !to the first-order version of sigma - q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation - - !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 - cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - !This form only allows cloud fractions out to q1 = -1.8 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.41*ATAN(1.55*q1(k)))) - !This form only allows cloud fractions out to q1 = -1 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.50*ATAN(1.55*q1(k)))) - - END DO - - endif !end sig_order option + END DO ! Specify hydrometeors ! JAYMES- this option added 8 May 2015 @@ -4172,10 +4063,6 @@ SUBROUTINE mym_condensation (kts,kte, & IF (q1k < 0.) THEN !unsaturated ql_water = sgm(k)*EXP(1.2*q1k-1) ql_ice = sgm(k)*EXP(1.2*q1k-1.) - !Reduce ice mixing ratios in the upper troposphere -! low_weight = MIN(MAX(p(k)-40000.0, 0.0),40000.0)/40000.0 -! ql_ice = low_weight * sgm(k)*EXP(1.1*q1k-1.6) & !low-lev -! + (1.-low_weight) * sgm(k)*EXP(1.1*q1k-2.8)!upper-lev ELSE IF (q1k > 2.) THEN !supersaturated ql_water = sgm(k)*q1k ql_ice = sgm(k)*q1k @@ -4276,11 +4163,14 @@ SUBROUTINE mym_condensation (kts,kte, & ! dampen the amplification factor (cld_factor) with height in order ! to limit excessively large cloud fractions aloft - fac_damp = 1.! -MIN(MAX( zagl-(PBLH2+1000.),0.0)/ & + !fac_damp = 1.! -MIN(MAX( zagl-(PBLH2+1000.),0.0)/ & ! MAX((zw(k_tropo)-(PBLH2+1000.)),500.), 1.) + fac_damp = min(zagl * 0.01, 1.0) !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.5 ) / 0.51 )**3.3 - cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 - cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.80 )) / 0.21 )**2 + !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 + !cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.80 )) / 0.22 )**2 + cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.90 )) / 0.11 )**2 + !cld_factor = 1.0 cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) ENDDO @@ -5300,25 +5190,27 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! sqv, sqc, sqi, thl, & ! dqv, dqc, dqi, dth ) - problem = .false. - do k=kts,kte - wsp = sqrt(u(k)**2 + v(k)**2) - wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2) - if (wsp2 > 200.) then - problem = .true. - print*,"Problem: i=",i," k=",k," wsp=",wsp2 - print*," du=",du(k)*delt," dv=",dv(k)*delt - print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) - print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc - print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(k) - kproblem = k + if (debug_code) then + problem = .false. + do k=kts,kte + wsp = sqrt(u(k)**2 + v(k)**2) + wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2) + if (wsp2 > 200.) then + problem = .true. + print*,"Huge wind speed: i=",i," k=",k," wsp=",wsp2 + print*," du=",du(k)*delt," dv=",dv(k)*delt + print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) + print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc + print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(kts) + kproblem = k + endif + enddo + if (problem) then + print*,"=temp:",thl(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"===qv:",sqv(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"====u:",u(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"====v:",v(max(kproblem-5,1):min(kproblem+5,kte)) endif - enddo - if (problem) then - print*,"=temp:",thl(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"===qv:",sqv(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"====u:",u(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"====v:",v(max(kproblem-5,1):min(kproblem+5,kte)) endif #ifdef HARDCODE_VERTICAL @@ -6025,7 +5917,7 @@ SUBROUTINE DMP_mf( & REAL :: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & - Wn2,Wn,EntEXP,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int + Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int ! w parameters REAL,PARAMETER :: & @@ -6066,7 +5958,7 @@ SUBROUTINE DMP_mf( & ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,& + REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,qsat_tk,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & Ac_mf,Ac_strat,qc_mf @@ -6250,13 +6142,14 @@ SUBROUTINE DMP_mf( & !Criteria (2) maxwidth = 1.1*PBLH ! Criteria (3) - maxwidth = MIN(maxwidth,0.333*cloud_base) + maxwidth = MIN(maxwidth,0.5*cloud_base) ! Criteria (4) wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01)) !Note: area fraction (acfac) is modified below ! Criteria (5) - only a function of flt (not fltv) if ((landsea-1.5).LT.0) then !land - width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) + !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.) else !water width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.003)/0.01) + .5),1000.), 0.) endif @@ -6264,7 +6157,7 @@ SUBROUTINE DMP_mf( & ! Convert maxwidth to number of plumes NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2) - !Initialize values: + !Initialize values for 2d output fields: ktop = 0 ztop = 0.0 maxmf= 0.0 @@ -6286,7 +6179,8 @@ SUBROUTINE DMP_mf( & ! Make updraft area (UPA) a function of the buoyancy flux if ((landsea-1.5).LT.0) then !land !acfac = .5*tanh((fltv2 - 0.03)/0.09) + .5 - acfac = .5*tanh((fltv2 - 0.02)/0.09) + .5 + !acfac = .5*tanh((fltv2 - 0.02)/0.09) + .5 + acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5 else !water acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5 endif @@ -6404,16 +6298,17 @@ SUBROUTINE DMP_mf( & DO k=KTS+1,KTE-1 !Entrainment from Tian and Kuang (2016) !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l) - !wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh - !ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),0.9)*l) + wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh + ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),0.9)*l) !Entrainment from Negggers (2015, JAMES) !ENT(k,i) = 0.02*l**-0.35 - 0.0009 - ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity + !ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity + !ENT(k,i) = 0.04*l**-0.495 - 0.0009 !"neg1+" !Minimum background entrainment ENT(k,i) = max(ENT(k,i),0.0003) - ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang + !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang !JOE - increase entrainment for plumes extending very high. IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN @@ -6425,18 +6320,19 @@ SUBROUTINE DMP_mf( & ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) - ! Define environment U & V at the model interface levels - Uk =(U(k)*DZ(k+1)+U(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - Ukm1=(U(k-1)*DZ(k)+U(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) - Vk =(V(k)*DZ(k+1)+V(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - Vkm1=(V(k-1)*DZ(k)+V(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + ! Define environment U & V at the model interface levels + Uk =(U(k)*DZ(k+1)+U(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + Ukm1=(U(k-1)*DZ(k)+U(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + Vk =(V(k)*DZ(k+1)+V(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + Vkm1=(V(k-1)*DZ(k)+V(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) ! Linear entrainment: EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) + EntExm= EntExp*0.3333 !reduce entrainment for momentum QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp - Un =UPU(k-1,I) *(1.-EntExp) + U(k)*EntExp + dxsa*pgfac*(Uk - Ukm1) - Vn =UPV(k-1,I) *(1.-EntExp) + V(k)*EntExp + dxsa*pgfac*(Vk - Vkm1) + Un =UPU(k-1,I) *(1.-EntExm) + U(k)*EntExm + dxsa*pgfac*(Uk - Ukm1) + Vn =UPV(k-1,I) *(1.-EntExm) + V(k)*EntExm + dxsa*pgfac*(Vk - Vkm1) QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp @@ -6876,11 +6772,10 @@ SUBROUTINE DMP_mf( & ENDIF !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq - xl = xl_blend(tk(k)) ! obtain blended heat capacity - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + xl = xl_blend(tk(k)) ! obtain blended heat capacity + qsat_tk = qsat_blend(tk(k),p(k)) ! get saturation water vapor mixing ratio + ! at t and p + rsl = xl*qsat_tk / (r_v*tk(k)**2) ! slope of C-C curve at t (abs temp) ! CB02, Eqn. 4 cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" @@ -6896,8 +6791,7 @@ SUBROUTINE DMP_mf( & ! conversion is neglected here. qww = 1.+0.61*qt(k) alpha = 0.61*pt - t = TH(k)*exner(k) - beta = pt*xl/(t*cp) - 1.61*pt + beta = pt*xl/(tk(k)*cp) - 1.61*pt !Buoyancy flux terms have been moved to the end of this section... !Now calculate convective component of the cloud fraction: @@ -6907,20 +6801,24 @@ SUBROUTINE DMP_mf( & f = 1.0 endif - sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & - & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) - sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components - sigq = MAX(sigq, 1.0E-6) + !CB form: + !sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & + ! & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components + !Per S.DeRoode 2009? + sigq = 10. * edmf_a(k) * (edmf_qt(k)-qt(k)) + + sigq = MAX(sigq, 1.0E-6) - qmq = a * (qt(k) - qsat_tl) ! saturation deficit/excess; + qmq = a * (qt(k) - qsat_tk) ! saturation deficit/excess; ! the numerator of Q1 mf_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) !IF ( debug_code ) THEN ! print*,"In MYNN, StEM edmf" - ! print*," CB: env qt=",qt(k)," qsat=",qsat_tl - ! print*," k=",k," satdef=",QTp - qsat_tl," sgm=",sgm(k) - ! print*," CB: sigq=",sigq," qmq=",qmq," tlk=",tlk + ! print*," CB: env qt=",qt(k)," qsat=",qsat_tk + ! print*," k=",k," satdef=",QTp - qsat_tk," sgm=",sgm(k) + ! print*," CB: sigq=",sigq," qmq=",qmq," tk=",tk(k) ! print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) !ENDIF @@ -6941,7 +6839,7 @@ SUBROUTINE DMP_mf( & !The mixing ratios from the stratus component are not well !estimated in shallow-cumulus regimes. Ensure stratus clouds !have mixing ratio similar to cumulus - QCs = MIN(MAX(qc_bl1d(k), 0.5*qc_mf), 5E-4) + QCs = MAX(qc_bl1d(k), 0.5*qc_mf) qc_bl1d(k) = (qc_mf*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) ELSE !cldfra_bl1d(k)=0.5*(edmf_a(k)+edmf_a(k-1)) @@ -6951,7 +6849,7 @@ SUBROUTINE DMP_mf( & cldfra_bl1d(k)=Ac_mf + Ac_strat qc_mf = QCp !Ensure stratus clouds have mixing ratio similar to cumulus - QCs = MIN(MAX(qc_bl1d(k), 0.5*qc_mf), 5E-4) + QCs = MAX(qc_bl1d(k), 0.5*qc_mf) qc_bl1d(k) = (QCp*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) ENDIF ELSE @@ -7197,7 +7095,7 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & REAL :: minrad,zminrad, radflux, F0, wst_rad, wst_dd logical :: cloudflg - REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,diffqt,& + REAL :: sigq,xl,rsl,cpm,a,mf_cf,diffqt,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid ! w parameters @@ -7669,7 +7567,6 @@ FUNCTION xl_blend(t) IF (t .GE. t0c) THEN xl_blend = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation -! ELSE IF (t .LE. 253.) THEN ELSE IF (t .LE. tice) THEN xl_blend = xls + (cpv-cice)*(t-t0c) !sublimation/deposition ELSE From 8e6580eec9c890a0917b6d2c9063fafa0dd73b80 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 22 Mar 2022 20:33:14 +0000 Subject: [PATCH 136/217] Syntax error --- physics/rad_sw_pre.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rad_sw_pre.F90 b/physics/rad_sw_pre.F90 index 8397387b1..8c33c17b8 100644 --- a/physics/rad_sw_pre.F90 +++ b/physics/rad_sw_pre.F90 @@ -24,7 +24,7 @@ subroutine rad_sw_pre_run (im, lsswr, coszen, nday, idxday, errmsg, errflg) ! Inputs integer, intent(in) :: im logical, intent(in) :: lsswr - realkind_phys), dimension(:), intent(in) :: coszen + real(kind_phys), dimension(:), intent(in) :: coszen ! Outputs integer, intent(out) :: nday From 726f4a6283c6bb7fb5a7bac4532889f49e63701a Mon Sep 17 00:00:00 2001 From: rongqian yang Date: Wed, 23 Mar 2022 18:45:52 +0000 Subject: [PATCH 137/217] Driver update, opt_trs=4 over vegetation, and z0hover bare soil etc. --- physics/module_sf_noahmplsm.f90 | 58 ++++++++++++++++++++++++++++----- physics/sfc_noahmp_drv.F90 | 10 +++++- 2 files changed, 59 insertions(+), 9 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 09faf0e05..7e3460ddf 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -3967,6 +3967,10 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity real (kind=kind_phys), intent( out) :: csigmaf1 ! real (kind=kind_phys) :: czil1 ! canopy based czil + real (kind=kind_phys) :: dlf ! leaf dimension + real(kind=kind_phys) :: kbsigmaf1 ! kb^-1 for fully convered by vegetation + real(kind=kind_phys) :: sigmaa ! kb^-1 for fully convered by vegetation + real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 @@ -4012,7 +4016,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & qsfc = 0.622*eair/(psfc-0.378*eair) ! canopy height - + dlf = parameters%dleaf !leaf dimension hcan = parameters%hvt uc = ur*log(hcan/z0m)/log(zlvl/z0m) uc = ur*log((hcan-zpd+z0m)/z0m)/log(zlvl/z0m) ! mb: add zpd v3.7 @@ -4058,8 +4062,11 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 cir = (2.-emv*(1.-emg))*emv*sb ! + if(opt_sfc == 4) then + gdx = sqrt(garea1) snwd = snowh * 1000.0 + fv = ustarx !inout in sfcdif4 if (snowh .gt. 0.1) then mnice = 1 @@ -4067,6 +4074,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & mnice = 0 endif + endif + ! --------------------------------------------------------------------------------------------- loop1: do iter = 1, niterc ! begin stability iteration @@ -4087,6 +4096,10 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & else z0h = z0m*0.01 endif + elseif (opt_trs == 4) then + sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) + kbsigmaf1 = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) + z0h = z0m/exp(kbsigmaf1) endif ! aerodyn resistances between heights zlvl and d+z0v @@ -4525,6 +4538,10 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: cev !coefficients for ev as function of esat[ts] real (kind=kind_phys) :: cgh !coefficients for st as function of ts + real(kind=kind_phys) :: kbsigmaf0 + real(kind=kind_phys) :: reynb + + !jref:start real (kind=kind_phys) :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m) real (kind=kind_phys) :: rawb2 !aerodynamic resistance for water vapor 2m (s/m) @@ -4597,6 +4614,18 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & cir = emg*sb cgh = 2.*df(isnow+1)/dzsnso(isnow+1) + reynb = ustarx*z0m/(1.5e-05) + + if (reynb .gt. 2.0) then + kbsigmaf0 = 2.46*reynb**0.25 - log(7.4) + else + kbsigmaf0 = - log(0.397) + endif + + z0h = max(z0m/exp(kbsigmaf0),1.0e-6) + + if (opt_sfc == 4) then + fv = ustarx gdx = sqrt(garea1) snwd = snowh * 1000.0 @@ -4605,6 +4634,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & else mnice = 0 endif + endif ! ----------------------------------------------------------------- loop3: do iter = 1, niterb ! begin stability iteration @@ -4767,17 +4797,11 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !jref:start; errors in original equation corrected. ! 2m air temperature + if(opt_sfc == 1 .or. opt_sfc ==2 .or. opt_sfc == 3) then ehb2 = fv*vkc/log((2.+z0h)/z0h) ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2b = ehb2 - endif - - if(opt_sfc == 4) then - ehb2 = 1. /(max(1.,1./ch2b*wspdb)) - cq2b = 1. /(max(1.,1./cq2b*wspdb)) - endif - if (ehb2.lt.1.e-5 ) then t2mb = tgb q2b = qsfc @@ -4785,6 +4809,24 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2 q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) endif + end if + + if(opt_sfc == 4) then ! consistent with veg + + rahb2 = max(1.,1./(ch2b*wspdb)) + ehb2 = 1./rahb2 + cq2b = 1./max(1.,1./(cq2b*wspdb)) ! + + if (ehb2.lt.1.e-5 ) then + t2mb = tgb + q2b = qsfc + else + t2mb = tgb - shb/(rhoair*cpair*ehb2) +! q2b = qsfc - qfx/(rhoair*cq2b) + q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) + end if + endif ! 4 + if (parameters%urban_flag) q2b = qsfc ! update ch diff --git a/physics/sfc_noahmp_drv.F90 b/physics/sfc_noahmp_drv.F90 index a16534364..ccd9f80f6 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/sfc_noahmp_drv.F90 @@ -553,6 +553,7 @@ subroutine noahmpdrv_run & real (kind=kind_phys) :: qfx real (kind=kind_phys) :: wspd1 ! wind speed with all components real (kind=kind_phys) :: pblhx ! height of pbl + integer :: mnice real (kind=kind_phys) :: rah_total ! real (kind=kind_phys) :: cah_total ! @@ -737,6 +738,13 @@ subroutine noahmpdrv_run & snow_ice_frac_old(k) = snow_level_ice(k) /(snow_level_ice(k)+snow_level_liquid(k)) end do + + if (snow_depth .gt. 0.1 .or. vegetation_category == isice_table ) then + mnice = 1 + else + mnice = 0 + endif + ! ! --- some outputs for atm model? ! @@ -1067,7 +1075,7 @@ subroutine noahmpdrv_run & call sfcdif4(i_location ,j_location ,uwind_forcing ,vwind_forcing , & temperature_forcing, air_pressure_forcing ,air_pressure_surface , & - pblhx,gdx,z0_total,itime,snwdph(i),0,psi_opt,surface_temperature, & + pblhx,gdx,z0_total,itime,snwdph(i),mnice,psi_opt,surface_temperature, & spec_humidity_forcing,forcing_height,iz0tlnd,spec_humidity_surface,& sensible_heat_total,qfx,cm(i),ch(i),ch2,cq2,rmol1(i),ustar1(i), & rb1(i),fm1(i),fh1(i),stress1(i),fm101(i),fh21(i),wspd1,flhc1(i), & From f7a9d915269de609bf2597e00f262d752bdf0e94 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Thu, 24 Mar 2022 15:56:20 +0000 Subject: [PATCH 138/217] GWD, LSM and MYNN physics updates from RRFS_dev branch --- physics/GFS_surface_composites.F90 | 31 +++++++++++++++++------ physics/GFS_surface_composites.meta | 36 ++++++++++++++++++++++++--- physics/drag_suite.F90 | 38 ++++++++++------------------- physics/module_sf_mynn.F90 | 2 +- physics/module_sf_ruclsm.F90 | 3 ++- 5 files changed, 73 insertions(+), 37 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 510b3f427..f44df5890 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -27,8 +27,9 @@ end subroutine GFS_surface_composites_pre_finalize !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! - subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, frac_grid, & - flag_cice, cplflx, cplice, cplwav2atm, landfrac, lakefrac, lakedepth, oceanfrac, frland, & + subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_cold_start, lkm, frac_grid, & + flag_cice, cplflx, cplice, cplwav2atm, lsm, lsm_ruc, & + landfrac, lakefrac, lakedepth, oceanfrac, frland, & dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & @@ -40,10 +41,11 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra implicit none ! Interface variables - integer, intent(in ) :: im, lkm, kdt - logical, intent(in ) :: flag_init, flag_restart, frac_grid, cplflx, cplice, cplwav2atm + integer, intent(in ) :: im, lkm, kdt, lsm, lsm_ruc + logical, intent(in ) :: flag_init, lsm_cold_start, frac_grid, cplflx, cplice, cplwav2atm logical, dimension(:), intent(inout) :: flag_cice logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet + real(kind=kind_phys), dimension(:), intent(in ) :: xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice real(kind=kind_phys), dimension(:), intent( out) :: frland @@ -201,12 +203,13 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif endif enddo - endif + endif ! frac_grid do i=1,im tprcp_wat(i) = tprcp(i) tprcp_lnd(i) = tprcp(i) tprcp_ice(i) = tprcp(i) + if (wet(i)) then ! Water uustar_wat(i) = uustar(i) tsfc_wat(i) = tsfco(i) @@ -219,7 +222,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif if (dry(i)) then ! Land uustar_lnd(i) = uustar(i) - weasd_lnd(i) = weasd(i) + if(lsm /= lsm_ruc) weasd_lnd(i) = weasd(i) tsurf_lnd(i) = tsfcl(i) ! DH* else @@ -230,7 +233,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) - weasd_ice(i) = weasd(i) + if(lsm /= lsm_ruc) weasd_ice(i) = weasd(i) tsurf_ice(i) = tisfc(i) ep1d_ice(i) = zero gflx_ice(i) = zero @@ -279,7 +282,17 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif enddo else + if(lsm /= lsm_ruc) then ! do not do snow initialization with RUC lsm do i=1,im + !-- print ice point + !if ( (xlon_d(i) > 298.6) .and. (xlon_d(i) < 298.7) .and. & + ! (xlat_d(i) > 68.6 ) .and. (xlat_d(i) < 68.7 )) then + ! print *,'Composit weasd_ice(i),snowd_ice',kdt,i,xlat_d(i),xlon_d(i),weasd_ice(i),snowd_ice(i) + !endif + !if ( (xlon_d(i) > 284.35) .and. (xlon_d(i) < 284.6) .and. & + ! (xlat_d(i) > 41.0 ) .and. (xlat_d(i) < 41.2 )) then + ! print *,'Composit2 weasd_lnd(i),snowd_lnd',kdt,i,xlat_d(i),xlon_d(i),weasd_lnd(i),snowd_lnd(i) + !endif if (icy(i)) then if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then snowd_lnd(i) = zero @@ -290,6 +303,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif endif enddo + endif ! lsm/=lsm_ruc endif ! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) @@ -644,6 +658,7 @@ subroutine GFS_surface_composites_post_run ( do i=1,im if (islmsk(i) == 1) then + !-- land zorl(i) = zorll(i) cd(i) = cd_lnd(i) cdq(i) = cdq_lnd(i) @@ -669,6 +684,7 @@ subroutine GFS_surface_composites_post_run ( hice(i) = zero cice(i) = zero elseif (islmsk(i) == 0) then + !-- water zorl(i) = zorlo(i) cd(i) = cd_wat(i) cdq(i) = cdq_wat(i) @@ -695,6 +711,7 @@ subroutine GFS_surface_composites_post_run ( hice(i) = zero cice(i) = zero else ! islmsk(i) == 2 + !-- ice zorl(i) = zorli(i) cd(i) = cd_ice(i) cdq(i) = cdq_ice(i) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 89048e487..40f0c940c 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -14,6 +14,22 @@ dimensions = () type = integer intent = in +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [flag_init] standard_name = flag_for_first_timestep long_name = flag signaling first time step for time integration loop @@ -21,9 +37,9 @@ dimensions = () type = logical intent = in -[flag_restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart +[lsm_cold_start] + standard_name = do_lsm_cold_start + long_name = flag to signify LSM is cold-started units = flag dimensions = () type = logical @@ -70,6 +86,20 @@ dimensions = () type = logical intent = in +[lsm] + standard_name = control_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in +[lsm_ruc] + standard_name = identifier_for_ruc_land_surface_scheme + long_name = flag for RUC land surface model + units = flag + dimensions = () + type = integer + intent = in [landfrac] standard_name = land_area_fraction long_name = fraction of horizontal grid area occupied by land diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 7fea98b13..fe9095210 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -589,17 +589,8 @@ subroutine drag_suite_run( & endif enddo -do i=1,im - if ( dx(i) .ge. dxmax_ss ) then - ss_taper(i) = 1. - else - if ( dx(i) .le. dxmin_ss) then - ss_taper(i) = 0. - else - ss_taper(i) = dxmax_ss * (1. - dxmin_ss/dx(i))/(dxmax_ss-dxmin_ss) - endif - endif -enddo +! Remove ss_tapering +ss_taper(:) = 1. ! SPP, if spp_gwd is 0, no perturbations are applied. if ( spp_gwd==1 ) then @@ -986,13 +977,11 @@ subroutine drag_suite_run( & enddo if((xland(i)-1.5).le.0. .and. 2.*varss_stoch(i).le.hpbl(i))then if(br1(i).gt.0. .and. thvx(i,kpbl2)-thvx(i,kts) > 0.)then - cleff_ss = sqrt(dxy(i)**2 + dxyp(i)**2) ! WRF + ! Modify xlinv to represent wave number of "typical" small-scale topography ! cleff_ss = 3. * max(dx(i),cleff_ss) ! cleff_ss = 10. * max(dxmax_ss,cleff_ss) - cleff_ss = 0.1 * max(dxmax_ss,cleff_ss) ! WRF ! cleff_ss = 0.1 * 12000. - coefm_ss(i) = (1. + olss(i)) ** (oass(i)+1.) - xlinv(i) = coefm_ss(i) / cleff_ss + xlinv(i) = 0.001*pi ! 2km horizontal wavelength !govrth(i)=g/(0.5*(thvx(i,kpbl(i))+thvx(i,kts))) govrth(i)=g/(0.5*(thvx(i,kpbl2)+thvx(i,kts))) !XNBV=sqrt(govrth(i)*(thvx(i,kpbl(i))-thvx(i,kts))/hpbl(i)) @@ -1003,8 +992,8 @@ subroutine drag_suite_run( & !tauwavex0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*u1(i,kpbl(i)) !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,kpbl2) !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,3) - var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & - MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch(i))) + ! Remove limit on varss_stoch + var_temp = varss_stoch(i) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero tauwavex0=var_temp2*u1(i,kvar)/(1.+var_temp2*deltim) @@ -1018,8 +1007,8 @@ subroutine drag_suite_run( & !tauwavey0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*v1(i,kpbl(i)) !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,kpbl2) !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,3) - var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & - MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch(i))) + ! Remove limit on varss_stoch + var_temp = varss_stoch(i) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero tauwavey0=var_temp2*v1(i,kvar)/(1.+var_temp2*deltim) @@ -1083,17 +1072,16 @@ subroutine drag_suite_run( & IF ((xland(i)-1.5) .le. 0.) then !(IH*kflt**n1)**-1 = (0.00102*0.00035**-1.9)**-1 = 0.00026615161 - var_temp = MIN(varss_stoch(i),varmax_fd_stoch(i)) + & - MAX(0.,beta_fd*(varss_stoch(i)-varmax_fd_stoch(i))) - var_temp = MIN(var_temp, 250.) + ! Remove limit on varss_stoch + var_temp = varss_stoch(i) + !var_temp = MIN(var_temp, 250.) a1=0.00026615161*var_temp**2 ! a1=0.00026615161*MIN(varss(i),varmax)**2 ! a1=0.00026615161*(0.5*varss(i))**2 ! k1**(n1-n2) = 0.003**(-1.9 - -2.8) = 0.003**0.9 = 0.005363 a2=a1*0.005363 - ! Revise e-folding height based on PBL height and topographic std. dev. -- M. Toy 3/12/2018 - H_efold = max(2*varss_stoch(i),hpbl(i)) - H_efold = min(H_efold,1500.) + ! Beljaars H_efold + H_efold = 1500. DO k=kts,km wsp=SQRT(u1(i,k)**2 + v1(i,k)**2) ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 5f227750a..65e83c93d 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -112,7 +112,7 @@ MODULE module_sf_mynn !1: check input !2: everything - heavy I/O LOGICAL, PARAMETER :: compute_diag = .false. - LOGICAL, PARAMETER :: compute_flux = .false. !shouldn't need compute + LOGICAL, PARAMETER :: compute_flux = .true. !shouldn't need compute ! these in FV3. They will be written over anyway. ! Computing the fluxes here is leftover from the WRF world. diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index b39610bc8..01e9c1100 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -2595,7 +2595,8 @@ SUBROUTINE SOIL (debug_print, & ! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct ! evaporation. Therefore , it is replaced with ref*0.7. !fc=max(qmin,ref*0.5) - fc=max(qmin,ref*0.7) + !fc=max(qmin,ref*0.7) + fc=ref fex_fc=1. if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then soilres = 1. From 81a326afa210c402144e9dddc56a45f85c745a70 Mon Sep 17 00:00:00 2001 From: helin wei Date: Thu, 24 Mar 2022 20:18:12 +0000 Subject: [PATCH 139/217] put a upper/lower limit on cwpc --- physics/module_sf_noahmplsm.f90 | 1 + physics/sfcsub.F | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index cdc43635b..98364b19c 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4688,6 +4688,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in cwpc = (cwp * vai * hcan * fhg)**0.5 ! cwpc = (cwp*fhg)**0.5 + cwpc = max(min(cwpc,5.0),1.0) tmp1 = exp( -cwpc*z0hg/hcan ) tmp2 = exp( -cwpc*(z0h+zpd)/hcan ) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index cdc91cca9..78e5201be 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -34,7 +34,6 @@ module sfccyc_module integer, parameter :: kpdalf(2)=(/214,217/) ! real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 -! integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata integer, parameter :: xdata=7200, ydata=3600, mdata=xdata*ydata integer :: veg_type_landice integer :: soil_type_landice From 7a16e21a3a0b9edb588c5fc644c6c1c7d819855f Mon Sep 17 00:00:00 2001 From: HelinWei-NOAA <48133472+HelinWei-NOAA@users.noreply.github.com> Date: Thu, 24 Mar 2022 17:17:54 -0400 Subject: [PATCH 140/217] Revert "Lsm upgrades mynn for p8c" --- physics/module_sf_noahmp_glacier.f90 | 101 +- physics/module_sf_noahmplsm.f90 | 1460 +------------------------- physics/sfc_noahmp_drv.F90 | 114 +- physics/sfc_noahmp_drv.meta | 53 - 4 files changed, 24 insertions(+), 1704 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index 997166744..c4c03aaf8 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -7,7 +7,6 @@ module noahmp_glacier_globals use machine , only : kind_phys use sfc_diff, only : stability - use module_sf_noahmplsm, only : sfcdif4 implicit none @@ -123,9 +122,7 @@ subroutine noahmp_glacier (& iloc ,jloc ,cosz ,nsnow ,nsoil ,dt , & ! in : time/space/model-related sfctmp ,sfcprs ,uu ,vv ,q2 ,soldn , & ! in : forcing prcp ,lwdn ,tbot ,zlvl ,ficeold ,zsoil , & ! in : forcing - thsfc_loc ,prslkix ,prsik1x ,prslk1x , & - psfc ,pblhx ,iz0tlnd ,itime , & - sigmaf1 ,garea1 ,psi_opt , & ! in : + thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & ! in : qsnow ,sneqvo ,albold ,cm ,ch ,isnow , & ! in/out : sneqv ,smc ,zsnso ,snowh ,snice ,snliq , & ! in/out : tg ,stc ,sh2o ,tauss ,qsfc , & ! in/out : @@ -152,8 +149,6 @@ subroutine noahmp_glacier (& real (kind=kind_phys) , intent(in) :: cosz !< cosine solar zenith angle [0-1] integer , intent(in) :: nsnow !< maximum no. of snow layers integer , intent(in) :: nsoil !< no. of soil layers - integer , intent(in) :: psi_opt - real (kind=kind_phys) , intent(in) :: dt !< time step [sec] real (kind=kind_phys) , intent(in) :: sfctmp !< surface air temperature [k] real (kind=kind_phys) , intent(in) :: sfcprs !< pressure (pa) @@ -171,12 +166,6 @@ subroutine noahmp_glacier (& real (kind=kind_phys) , intent(in) :: prslkix !< pressure (pa) real (kind=kind_phys) , intent(in) :: prsik1x !< pressure (pa) real (kind=kind_phys) , intent(in) :: prslk1x !< pressure (pa) - - real (kind=kind_phys) , intent(in) :: psfc ! surface pressure - real (kind=kind_phys) , intent(in) :: pblhx ! pbl height - integer , intent(in) :: iz0tlnd ! - integer , intent(in) :: itime !< timestep - real (kind=kind_phys) , intent(in) :: sigmaf1 !< areal fractional cover of green vegetation real (kind=kind_phys) , intent(in) :: garea1 !< area of the grid cell @@ -285,7 +274,6 @@ subroutine noahmp_glacier (& vv ,solad ,solai ,cosz ,zlvl , & !in tbot ,zbot ,zsnso ,dzsnso ,sigmaf1 ,garea1 , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & !in - psfc ,pblhx ,iz0tlnd ,itime ,psi_opt , & tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout #ifdef CCPP @@ -417,7 +405,6 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair vv ,solad ,solai ,cosz ,zref , & !in tbot ,zbot ,zsnso ,dzsnso ,sigmaf1 ,garea1 , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & !in - psfc ,pblhx ,iz0tlnd ,itime ,psi_opt , & tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout #ifdef CCPP @@ -440,8 +427,6 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair ! inputs integer , intent(in) :: nsnow !< maximum no. of snow layers integer , intent(in) :: nsoil !< number of soil layers - integer , intent(in) :: psi_opt - integer , intent(in) :: isnow !< actual no. of snow layers real (kind=kind_phys) , intent(in) :: dt !< time step [sec] real (kind=kind_phys) , intent(in) :: qsnow !< snowfall on the ground (mm/s) @@ -466,12 +451,6 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair real (kind=kind_phys) , intent(in) :: prslkix ! in exner function real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function - - real (kind=kind_phys) , intent(in) :: pblhx !< PBL height (m) - real (kind=kind_phys) , intent(in) :: psfc !< surface pressure - integer , intent(in) :: iz0tlnd !< z0t option - integer , intent(in) :: itime !< integration time - real (kind=kind_phys) , intent(in) :: sigmaf1 !< areal fractional cover of green vegetation real (kind=kind_phys) , intent(in) :: garea1 !< area of the grid cell @@ -582,9 +561,7 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in - thsfc_loc ,prslkix ,prsik1x ,prslk1x , & - psfc ,pblhx ,iz0tlnd ,itime ,uu ,vv , & - sigmaf1 ,garea1 ,psi_opt , & !in + thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & !in #ifdef CCPP cm ,ch ,tg ,qsfc ,errmsg ,errflg , & !inout #else @@ -1020,9 +997,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in - thsfc_loc ,prslkix ,prsik1x ,prslk1x , & - psfc ,pblhx ,iz0tlnd ,itime ,uu ,vv , & - sigmaf1 ,garea1 ,psi_opt , & !in + thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & !in #ifdef CCPP cm ,ch ,tgb ,qsfc ,errmsg ,errflg , & !inout #else @@ -1045,8 +1020,6 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! input integer, intent(in) :: nsnow !< maximum no. of snow layers integer, intent(in) :: nsoil !< number of soil layers - integer, intent(in) :: psi_opt - real (kind=kind_phys), intent(in) :: emg !< ground emissivity integer, intent(in) :: isnow !< actual no. of snow layers real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df !< thermal conductivity of snow/soil (w/m/k) @@ -1075,14 +1048,6 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso real (kind=kind_phys), intent(in) :: prslkix ! in exner function real (kind=kind_phys), intent(in) :: prsik1x ! in exner function real (kind=kind_phys), intent(in) :: prslk1x ! in exner function - - real (kind=kind_phys) , intent(in) :: pblhx !< - real (kind=kind_phys) , intent(in) :: psfc !< - integer , intent(in) :: iz0tlnd !< - integer , intent(in) :: itime !< integration time - real (kind=kind_phys) , intent(in) :: uu !< - real (kind=kind_phys) , intent(in) :: vv !< - real (kind=kind_phys), intent(in) :: sigmaf1 ! real (kind=kind_phys), intent(in) :: garea1 ! @@ -1130,19 +1095,11 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso integer :: iter !< iteration index real (kind=kind_phys) :: z0h !< roughness length, sensible heat, ground (m) - real (kind=kind_phys) :: qfx - real (kind=kind_phys) :: cq2 !< surface exchange at 2m - - real(kind=kind_phys) :: rb1i ! bulk richardson # real(kind=kind_phys) :: fm10i ! fm10 over land ice real(kind=kind_phys) :: stress1i! wind stress m2 S-2 - real(kind=kind_phys) :: wspd1i - real(kind=kind_phys) :: flhc1i - real(kind=kind_phys) :: flqc1i - real(kind=kind_phys) :: tv1i ! virtual potential temp @ ref level real(kind=kind_phys) :: thv1i ! virtual potential temp @ ref level @@ -1192,10 +1149,6 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso h = 0. - fh2 = 0. - qfx = 0. - - ! the following only applies to opt_sfc =3, opt_sfc = 1 still done its old way snwd = snowh*1000.0 @@ -1241,10 +1194,8 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso tem2 = max(sigmaf1, 0.1_kind_phys) zvfun1= sqrt(tem1 * tem2) gdx=sqrt(garea1) - - if(opt_sfc == 1 .or. opt_sfc == 2 .or. opt_sfc == 4) then !Add option for sfc scheme,use '1' for both '1'/'2' + if(opt_sfc == 1 .or. opt_sfc == 2) then !Add option for sfc scheme,use '1' for both '1'/'2' loop3: do iter = 1, niterb ! begin stability iteration - if(opt_sfc == 1 .or. opt_sfc == 2) then ! for now, only allow sfcdif1 until others can be fixed @@ -1260,45 +1211,8 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso #ifdef CCPP if (errflg /= 0) return #endif - endif - - if(opt_sfc == 4) then - - call sfcdif4(1 ,1 ,uu ,vv ,sfctmp , & !allow location for use in the driver - sfcprs ,psfc ,pblhx ,gdx ,z0m , & - itime ,snwd ,1 ,psi_opt, & - tgb ,qair ,zlvl ,iz0tlnd,qsfc , & ! use zlvli? - h ,qfx ,cm ,ch ,ch2 , & ! ch2 = cq2 most of times - cq2 ,moz ,fv ,rb1i, fm, fh, & - stress1i,fm10i ,fh2 , wspd1i ,flhc1i ,flqc1i) ! some are for use in the driver call - - - ! Undo the multiplication by windspeed that SFCDIF4 - ! applies to exchange coefficients CH and CM: - - ch = ch / wspd1i - cm = cm / wspd1i - ch2 = ch2 / wspd1i - cq2 = cq2 / wspd1i - - if(snwd > 0.) then - cm = min(0.01,cm) - ch = min(0.01,ch) - ch2 = min(0.01,ch2) - cq2 = min(0.01,cq2) - end if - - endif ! 4 - - ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) - - if(opt_sfc == 4) then - ramb = max(1.,1./(cm*wspd1i) ) - rahb = max(1.,1./(ch*wspd1i) ) - endif - rawb = rahb ! es and d(es)/dt evaluated at tg @@ -1350,7 +1264,6 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso estg = esati end if qsfc = 0.622*(estg*rhsur)/(sfcprs-0.378*(estg*rhsur)) - qfx = (qsfc-qair)*cev*gamma/cpair end do loop3 ! end stability iteration end if @@ -1449,12 +1362,6 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! 2m air temperature ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2b = ehb2 - - if (opt_sfc == 4) then - ehb2 = ch2 * wspd1i ! need conductance,z0h from sfcdif4 - cq2b = cq2 * wspd1i ! conductance - endif - if (ehb2.lt.1.e-5 ) then t2mb = tgb q2b = qsfc diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 345864f2e..98364b19c 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -10,22 +10,10 @@ module module_sf_noahmplsm use machine , only : kind_phys use sfc_diff, only : stability - use physcons, only : rcp => con_rocp, & - & ep_1 => con_fvirt, & - & ep_2 => con_eps, & - & r_d => con_rd, & - & cp => con_cp, & - & g => con_g, & - & xlv => con_hvap - - implicit none public :: noahmp_options public :: noahmp_sflx - public :: sfcdif4 - public :: psi_init - private :: atm private :: phenology @@ -385,32 +373,6 @@ module module_sf_noahmplsm end type noahmp_parameters -! -! for sfcdif4 -! - real, parameter :: prt=1. !prandtl number - real, parameter :: p1000mb = 100000. - - real, parameter :: svp1 = 0.6112 - real, parameter :: svp2 = 17.67 - real, parameter :: svp3 = 29.65 - real, parameter :: svpt0 = 273.15 - real, parameter :: ep_3=1.-ep_2 - real, parameter :: ep2=ep_2 - real, parameter :: onethird = 1./3. - real, parameter :: sqrt3 = 1.7320508075688773 - real, parameter :: atan1 = 0.785398163397 !in radians - - real, parameter :: karman = 0.4 - real, parameter :: vconvc=1.25 - - real, parameter :: snowz0 = 0.011 - real, parameter :: wmin = 0.1 - - real, dimension(0:1000 ),save :: psim_stab,psim_unstab, & - psih_stab,psih_unstab - - contains ! !== begin noahmp_sflx ============================================================================== @@ -423,7 +385,6 @@ subroutine noahmp_sflx (parameters, & smceq , & ! in : vegetation/soil characteristics sfctmp , sfcprs , psfc , uu , vv , q2, garea1 , & ! in : forcing qc , soldn , lwdn,thsfc_loc, prslkix,prsik1x,prslk1x,& ! in : forcing - pblhx , iz0tlnd , itime ,psi_opt ,& prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing albold , sneqvo , & ! in/out : @@ -487,11 +448,6 @@ subroutine noahmp_sflx (parameters, & real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function real (kind=kind_phys) , intent(in) :: garea1 ! in exner function - real (kind=kind_phys) , intent(in) :: pblhx ! pbl height - integer , intent(in) :: iz0tlnd !< z0t option - integer , intent(in) :: itime !< - integer , intent(in) :: psi_opt !< - real (kind=kind_phys) , intent(inout) :: zlvl !< reference height (m) real (kind=kind_phys) , intent(in) :: cosz !< cosine solar zenith angle [0-1] real (kind=kind_phys) , intent(in) :: tbot !< bottom condition for soil temp. [k] @@ -726,6 +682,8 @@ subroutine noahmp_sflx (parameters, & logical :: crop_active !< flag to run crop model ! add canopy heat storage (C.He added based on GY Niu's communication) real :: canhs ! canopy heat storage change w/m2 +! maximum lai/sai used for some parameterizations based on plant growthi + ! intent (out) variables need to be assigned a value. these normally get assigned values ! only if dveg == 2. @@ -776,7 +734,7 @@ subroutine noahmp_sflx (parameters, & ! vegetation phenology call phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai ,igs, pgs) + lai , sai , troot , elai , esai ,igs, pgs) !input gvf should be consistent with lai if(dveg == 1 .or. dveg == 6 .or. dveg == 7) then @@ -820,11 +778,10 @@ subroutine noahmp_sflx (parameters, & sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in - pblhx ,iz0tlnd, itime ,psi_opt, & z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out @@ -1100,7 +1057,7 @@ end subroutine atm !!vegetation phenology considering vegetation canopy being buried by snow and !!evolution in time. subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai , igs, pgs) + lai , sai , troot , elai , esai , igs, pgs) ! -------------------------------------------------------------------------------------------------- ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time @@ -1659,11 +1616,10 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in - pblhx , iz0tlnd, itime,psi_opt, & z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out @@ -1744,11 +1700,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function real (kind=kind_phys) , intent(in) :: garea1 - real (kind=kind_phys) , intent(in) :: pblhx ! pbl height - integer , intent(in) :: iz0tlnd - integer , intent(in) :: itime - integer , intent(in) :: psi_opt - real (kind=kind_phys) , intent(in) :: qair !specific humidity (kg/kg) real (kind=kind_phys) , intent(in) :: sfctmp !air temperature (k) real (kind=kind_phys) , intent(in) :: thair !potential temperature (k) @@ -2090,7 +2041,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , fveg, & !in + lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2222,7 +2173,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in - pblhx ,iz0tlnd ,itime ,psi_opt , & eah ,tah ,tv ,tgv ,cmv, ustarx , & !inout #ifdef CCPP chv ,dx ,dz8w ,errmsg ,errflg , & !inout @@ -2259,7 +2209,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in emg ,stc ,df ,rsurf ,latheag , & !in gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in - pblhx ,iz0tlnd ,itime ,psi_opt , & #ifdef CCPP tgb ,cmb ,chb, ustarx,errmsg ,errflg , & !inout #else @@ -2312,11 +2261,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc q2e = fveg * q2v + (1.0 - fveg) * q2b -! effectibe skin temperature - - ts = (fveg*chv*tah + (1.0-fveg)*chb*tgb ) / ch - - ! new coupling code if (opt_trs == 1) then @@ -2487,7 +2431,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , fveg,& !in + lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2512,8 +2456,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: lat !latitude (radians) real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) - integer , intent(in) :: vegtyp !vegtyp type - real (kind=kind_phys), intent(in) :: fveg !green vegetation fraction [0.0-1.0] + integer , intent(in) :: vegtyp !vegtyp type ! outputs real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] @@ -2562,7 +2505,6 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) - df(1) = df(1) * exp (sbeta * fveg) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -3708,7 +3650,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in - fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -3716,7 +3658,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in - pblhx ,iz0tlnd ,itime ,psi_opt , & eah ,tah ,tv ,tg ,cm,ustarx,& !inout #ifdef CCPP ch ,dx ,dz8w ,errmsg ,errflg , & !inout @@ -3764,12 +3705,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in) :: dt !time step (s) real (kind=kind_phys), intent(in) :: fsno !snow fraction - real (kind=kind_phys) , intent(in) :: pblhx ! pbl height - integer , intent(in) :: iz0tlnd - integer , intent(in) :: itime - integer , intent(in) :: psi_opt - - real (kind=kind_phys), intent(in) :: snowh !actual snow depth [m] real (kind=kind_phys), intent(in) :: fwet !wetted fraction of canopy real (kind=kind_phys), intent(in) :: cwp !canopy wind parameter @@ -3853,10 +3788,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: wspd ! ------------------------ local variables ---------------------------------------------------- - real (kind=kind_phys) :: gdx !grid dx - real (kind=kind_phys) :: snwd ! snowdepth in mm - integer :: mnice ! MYNN ice flag - real (kind=kind_phys) :: cw !water vapor exchange coefficient real (kind=kind_phys) :: fv !friction velocity (m/s) real (kind=kind_phys) :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2) @@ -3920,15 +3851,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: ch2 !surface exchange at 2m real (kind=kind_phys) :: thstar !surface exchange at 2m - real (kind=kind_phys) :: fm10 - real (kind=kind_phys) :: rb1v - real (kind=kind_phys) :: stress1v - - - real (kind=kind_phys) :: flhcv ! for MYNN - real (kind=kind_phys) :: flqcv ! for MYNN - real (kind=kind_phys) :: wspdv ! for MYNN - real (kind=kind_phys) :: thvair real (kind=kind_phys) :: thah real (kind=kind_phys) :: rahc2 !aerodynamic resistance for sensible heat (s/m) @@ -3968,10 +3890,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity real (kind=kind_phys), intent( out) :: csigmaf1 ! real (kind=kind_phys) :: czil1 ! canopy based czil - real (kind=kind_phys) :: dlf ! leaf dimension - real(kind=kind_phys) :: kbsigmaf1 ! kb^-1 for fully convered by vegetation - real(kind=kind_phys) :: sigmaa ! kb^-1 for fully convered by vegetation - real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 @@ -4017,7 +3935,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & qsfc = 0.622*eair/(psfc-0.378*eair) ! canopy height - dlf = parameters%dleaf !leaf dimension + hcan = parameters%hvt uc = ur*log(hcan/z0m)/log(zlvl/z0m) uc = ur*log((hcan-zpd+z0m)/z0m)/log(zlvl/z0m) ! mb: add zpd v3.7 @@ -4062,21 +3980,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 cir = (2.-emv*(1.-emg))*emv*sb -! - if(opt_sfc == 4) then - - gdx = sqrt(garea1) - snwd = snowh * 1000.0 - fv = ustarx !inout in sfcdif4 - - if (snowh .gt. 0.1) then - mnice = 1 - else - mnice = 0 - endif - - endif - ! --------------------------------------------------------------------------------------------- loop1: do iter = 1, niterc ! begin stability iteration @@ -4097,10 +4000,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & else z0h = z0m*0.01 endif - elseif (opt_trs == 4) then - sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) - kbsigmaf1 = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) - z0h = z0m/exp(kbsigmaf1) endif ! aerodyn resistances between heights zlvl and d+z0v @@ -4134,43 +4033,14 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp, & !in - ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out endif - if(opt_sfc == 4) then - - call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , & - sfcprs ,psfc ,pblhx ,gdx ,z0m , & - itime ,snwd ,mnice ,psi_opt, & - tah ,qair ,zlvl ,iz0tlnd,qsfc , & - h ,qfx ,cm ,ch ,ch2v , & - cq2v ,moz ,fv ,rb1v, fm, fh, & - stress1v,fm10 ,fh2 ,wspdv ,flhcv ,flqcv) - - - ! Undo the multiplication by windspeed that SFCDIF4 - ! applies to exchange coefficients CH and CM - - ch = ch / wspdv - cm = cm / wspdv - ch2v = ch2v / wspdv - - endif - - ramc = max(1.,1./(cm*ur)) rahc = max(1.,1./(ch*ur)) - - if (opt_sfc == 4 ) then - ramc = max(1.,1./(cm*wspdv) ) - rahc = max(1.,1./(ch*wspdv) ) - endif - rawc = rahc ! aerodyn resistance between heights z0g and d+z0v, rag, and leaf @@ -4280,11 +4150,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! consistent specific humidity from canopy air vapor pressure qsfc = (0.622*eah)/(sfcprs-0.378*eah) - if ( opt_sfc == 4 ) then - qfx = (qsfc-qair)*rhoair*caw - endif - - if (liter == 1) then exit loop1 endif @@ -4364,15 +4229,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & cah2 = fv*vkc/log((2.+z0h)/z0h) cah2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2v = cah2 - endif - - if (opt_sfc == 4 ) then - rahc2 = max(1.,1./(ch2v*wspdv)) - rawc2 = rahc2 - cah2 = 1./rahc2 - cq2v = 1./max(1.,1./(cq2v*wspdv)) - endif - if (cah2 .lt. 1.e-5 ) then t2mv = tah ! q2v = (eah*0.622/(sfcprs - 0.378*eah)) @@ -4382,6 +4238,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! q2v = (eah*0.622/(sfcprs - 0.378*eah))- qfx/(rhoair*fv)* 1./vkc * log((2.+z0h)/z0h) q2v = qsfc - ((evc+tr)/fveg+evg)/(latheav*rhoair) * 1./cq2v endif + endif ! update ch for output ch = cah @@ -4402,7 +4259,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & emg ,stc ,df ,rsurf ,lathea , & !in gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in - pblhx , iz0tlnd , itime ,psi_opt ,& #ifdef CCPP tgb ,cm ,ch,ustarx,errmsg ,errflg , & !inout #else @@ -4455,12 +4311,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) real (kind=kind_phys), intent(in) :: fsno !snow fraction - real (kind=kind_phys), intent(in) :: pblhx !pbl height (m) - integer, intent(in) :: iz0tlnd - integer, intent(in) :: itime - integer, intent(in) :: psi_opt - - !jref:start; in integer , intent(in) :: ivgtyp real (kind=kind_phys) , intent(in) :: qc !cloud water mixing ratio @@ -4502,19 +4352,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! local variables - real (kind=kind_phys) :: gdx !grid dx - real (kind=kind_phys) :: snwd ! snowdepth in mm - integer :: mnice ! MYNN ice flag - - real (kind=kind_phys) :: fm10 - real (kind=kind_phys) :: rb1b - real (kind=kind_phys) :: stress1b - - real (kind=kind_phys) :: wspdb - real (kind=kind_phys) :: flhcb - real (kind=kind_phys) :: flqcb -! - real (kind=kind_phys) :: taux !wind stress: e-w (n/m2) real (kind=kind_phys) :: tauy !wind stress: n-s (n/m2) real (kind=kind_phys) :: fira !total net longwave rad (w/m2) [+ to atm] @@ -4541,10 +4378,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: cev !coefficients for ev as function of esat[ts] real (kind=kind_phys) :: cgh !coefficients for st as function of ts - real(kind=kind_phys) :: kbsigmaf0 - real(kind=kind_phys) :: reynb - - !jref:start real (kind=kind_phys) :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m) real (kind=kind_phys) :: rawb2 !aerodynamic resistance for water vapor 2m (s/m) @@ -4617,28 +4450,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & cir = emg*sb cgh = 2.*df(isnow+1)/dzsnso(isnow+1) - reynb = ustarx*z0m/(1.5e-05) - - if (reynb .gt. 2.0) then - kbsigmaf0 = 2.46*reynb**0.25 - log(7.4) - else - kbsigmaf0 = - log(0.397) - endif - - z0h = max(z0m/exp(kbsigmaf0),1.0e-6) - - if (opt_sfc == 4) then - fv = ustarx - gdx = sqrt(garea1) - snwd = snowh * 1000.0 - - if (snowh .gt. 0.1) then - mnice = 1 - else - mnice = 0 - endif - endif - ! ----------------------------------------------------------------- loop3: do iter = 1, niterb ! begin stability iteration @@ -4682,47 +4493,14 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 ,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out endif - if(opt_sfc == 4) then - - call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , & - sfcprs ,psfc ,pblhx ,gdx ,z0m , & - itime ,snwd ,mnice ,psi_opt , & - tgb ,qair ,zlvl ,iz0tlnd,qsfc , & - h ,qfx ,cm ,ch ,ch2b , & - cq2b ,moz ,fv ,rb1b, fm, fh , & - stress1b,fm10 ,fh2 , wspdb ,flhcb ,flqcb) - - ! Undo the multiplication by windspeed that SFCDIF4 - ! applies to exchange coefficients CH and CM: - - ch = ch / wspdb - cm = cm / wspdb - ch2b = ch2b / wspdb - cq2b = cq2b / wspdb - - if(snwd > 0.) then - cm = min(0.01,cm) - ch = min(0.01,ch) - ch2b = min(0.01,ch2b) - cq2b = min(0.01,cq2b) - end if - - endif ! 4 - ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) - - if(opt_sfc == 4) then - ramb = max(1.,1./(cm*wspdb) ) - rahb = max(1.,1./(ch*wspdb) ) - endif - rawb = rahb !jref - variables for diagnostics @@ -4800,7 +4578,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !jref:start; errors in original equation corrected. ! 2m air temperature - if(opt_sfc == 1 .or. opt_sfc ==2 .or. opt_sfc == 3) then ehb2 = fv*vkc/log((2.+z0h)/z0h) ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) @@ -4812,25 +4589,8 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2 q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) endif - end if - - if(opt_sfc == 4) then ! consistent with veg - - rahb2 = max(1.,1./(ch2b*wspdb)) - ehb2 = 1./rahb2 - cq2b = 1./max(1.,1./(cq2b*wspdb)) ! - - if (ehb2.lt.1.e-5 ) then - t2mb = tgb - q2b = qsfc - else - t2mb = tgb - shb/(rhoair*cpair*ehb2) -! q2b = qsfc - qfx/(rhoair*cq2b) - q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) - end if - endif ! 4 - if (parameters%urban_flag) q2b = qsfc + end if ! update ch ch = ehb @@ -5345,7 +5105,7 @@ end subroutine sfcdif2 !! compute surface drag coefficient cm for momentum and ch for heat. subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,vegetated,vaie ,vegtyp , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf ,cm ,ch ) !out @@ -9991,1195 +9751,5 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc end subroutine noahmp_options - subroutine sfcdif4(iloc ,jloc ,ux ,vx ,t1d , & - p1d ,psfcpa,pblhx ,dx ,znt , & - itime ,snwh ,isice ,psi_opt, & - tsk ,qx ,zlvl ,iz0tlnd,qsfc , & - hfx ,qfx ,cm ,chs ,chs2 , & - cqs2 , & - rmolx ,ust , rbx, fmx, fhx,stressx,& - fm10x, fh2x, wspdx,flhcx,flqcx) - - - -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------- - -! input - - integer,intent(in ) :: iloc - integer,intent(in ) :: jloc - integer, intent(in) :: itime - - integer, intent(in) :: psi_opt - - integer, intent(in) :: isice ! for the glacier/snowh > 0.1m - - real, intent(in ) :: pblhx ! planetary boundary layer height - real, intent(in ) :: tsk ! skin temperature - real, intent(in ) :: psfcpa ! pressure in pascal - real, intent(in ) :: p1d !lowest model layer pressure (pa) - real, intent(in ) :: t1d !lowest model layer temperature - real, intent(in ) :: qx !water vapor specific humidity (kg/kg) from input - real, intent(in ) :: zlvl ! thickness of lowest full level layer - real, intent(in ) :: hfx ! sensible heat flux - real, intent(in ) :: qfx ! moisture flux - real, intent(in ) :: dx ! horisontal grid spacing - real, intent(in ) :: ux ! u and v winds - real, intent(in ) :: vx - real, intent(in ) :: znt ! z0m in m or inout - real, intent(in ) :: snwh ! in mm - -! optional vars - - integer,optional,intent(in ) :: iz0tlnd - - real, intent(inout) :: qsfc - real, intent(inout) :: ust - real, intent(inout) :: chs - real, intent(inout) :: chs2 - real, intent(inout) :: cqs2 - real, intent(inout) :: cm - - real, intent(inout) :: rmolx - real, intent(inout) :: rbx - real, intent(inout) :: fmx - real, intent(inout) :: fhx - real, intent(inout) :: stressx - real, intent(inout) :: fm10x - real, intent(inout) :: fh2x - - real, intent(inout) :: wspdx - real, intent(inout) :: flhcx - real, intent(inout) :: flqcx - - real :: zolx - real :: molx - -! diagnostics out -! real, intent(out) :: u10 -! real, intent(out) :: v10 -! real, intent(out) :: th2 -! real, intent(out) :: t2 -! real, intent(out) :: q2 -! real, intent(out) :: qsfc - - -! local - - real :: za ! height of full-sigma level - real :: thvx ! virtual potential temperature - real :: zqkl ! height of upper half level - real :: zqklp1 ! height of lower half level (surface) - real :: thx ! potential temperature - real :: psih ! similarity function for heat - real :: psih2 ! similarity function for heat 2m - real :: psih10 ! similarity function for heat 10m - real :: psim ! similarity function for momentum - real :: psim2 ! similarity function for momentum 2m - real :: psim10 ! similarity function for momentum 10m - - real :: gz1oz0 ! log(za/z0) - real :: gz2oz0 ! log(z2/z0) - real :: gz10oz0 ! log(z10/z0) - - real :: rhox ! density - real :: govrth ! g/theta for stability l - real :: tgdsa ! tsk - real :: tvir ! temporal variable src4 -> tvir - real :: thgb ! potential temperature ground - real :: psfcx ! surface pressure - real :: cpm - real :: qgh - - integer :: n,i,k,kk,l,nzol,nk,nzol2,nzol10 - - real :: zolzt, zolz0, zolza - real :: gz1ozt,gz2ozt,gz10ozt - - - real :: pl,thcon,tvcon,e1 - real :: zl,tskv,dthvdz,dthvm,vconv,rzol,rzol2,rzol10,zol2,zol10 - real :: dtg,psix,dtthx,psix10,psit,psit2,psiq,psiq2,psiq10 - real :: fluxc,vsgd,z0q,visc,restar,czil,restar2 - - real :: dqg - real :: tabs - real :: qsfcmr - real :: t1dc - real :: zt - real :: zq - real :: zratio - real :: qstar -!------------------------------------------------------------------- - - psfcx=psfcpa/1000. ! to kPa for saturation check - - if (itime == 1) then !init SP, MR - if (isice == 0) then - tabs = 0.5*(tsk + t1d) - if (tabs .lt. 273.15) then - !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) - e1=svp1*exp(4648*(1./273.15 - 1./tabs) - & - & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs)) - else - !saturation vapor pressure wrt water (bolton 1980) - e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3)) - endif - - qsfc =ep2*e1/(psfcx-ep_3*e1) !avg with the input? - qsfcmr =qsfc/(1.-qsfc) !to mixing ratio - endif - - if (isice == 1) then - if (tsk .lt. 273.15) then - !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) - e1=svp1*exp(4648*(1./273.15 - 1./tsk) - & - & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk)) - else - !saturation vapor pressure wrt water (bolton 1980) - e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3)) - endif - - qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity - qsfcmr=ep2*e1/(psfcx-e1) !mixing ratio - - endif - - else - ! use what comes out of the lsm - if (isice == 0) then - tabs = 0.5*(tsk + t1d) - if (tabs .lt. 273.15) then - !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) - e1=svp1*exp(4648*(1./273.15 - 1./tabs) - & - & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs)) - else - !saturation vapor pressure wrt water (bolton 1980) - e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3)) - endif - - qsfc =ep2*e1/(psfcx-ep_3*e1) ! avg with previous qsfc? - qsfcmr=qsfc/(1.-qsfc) - - endif - - if (isice == 1) then - if (tsk .lt. 273.15) then - !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) - e1=svp1*exp(4648*(1./273.15 - 1./tsk) - & - & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk)) - else - !saturation vapor pressure wrt water (bolton 1980) - e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3)) - endif - - qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity - qsfcmr=qsfc/(1.-qsfc) - - endif - - endif !done INIT if itime=1 -! convert (tah or tgb = tsk) temperature to potential temperature. - tgdsa = tsk - thgb = tsk*(p1000mb/psfcpa)**rcp !psfcpa is pa - -! store virtual, virtual potential and potential temperature - - pl = p1d/1000. - thx = t1d*(p1000mb*0.001/pl)**rcp - t1dc = t1d - 273.15 - - thvx = thx*(1.+ep_1*qx) !qx is SH from input - tvir = t1d*(1.+ep_1*qx) - - rhox=psfcx*1000./(r_d*tvir) - govrth=g/thx - za = zlvl - - !za=0.5*dz8w - - -! directly from input; check units - -! qfx = qflx * rhox -! hfx = hflx * rhox * cp - - - -! q2sat = qgh in lsm -!jref: canres and esat is calculated in the loop so should that be changed?? -! qgh=ep_2*e1/(pl-e1) -! cpm=cp*(1.+0.8*qx) - - -! qgh changed to use lowest-level air temp - - if (t1d .lt. 273.15) then - !saturation vapor pressure wrt ice - e1=svp1*exp(4648.*(1./273.15 - 1./t1d) - & - & 11.64*log(273.15/t1d) + 0.02265*(273.15 - t1d)) - else - !saturation vapor pressure wrt water (bolton 1980) - e1=svp1*exp(svp2*(t1d-svpt0)/(t1d-svp3)) - endif - - - !qgh=ep2*e1/(pl-ep_3*e1) !specific humidity - - qgh=ep2*e1/(pl-e1) !sat. mixing ratio ? - -! cpm=cp*(1.+0.84*qx) ! qx is SH - cpm=cp*(1.+0.84*qx/(1.0-qx) ) - - wspdx=sqrt(ux*ux+vx*vx) - - tskv=thgb*(1.+ep_1*qsfc) !avg with tsurf not used - dthvdz=(thvx-tskv) - - fluxc = max(hfx/rhox/cp + ep_1*tskv*qfx/rhox,0.) !hfx + qfx are fluxes units: wm^-2 and kg m^-2 s^-1 -! vconv = vconvc*(g/tgdsa*pblh*fluxc)**.33 - - vconv = vconvc*(g/tgdsa*min(1.5*pblhx,4000.0)*fluxc)**.33 !wstar -! vsgd = 0.32 * (max(dx/5000.-1.,0.))**.33 - - vsgd = min(0.32 * (max(dx/5000.-1.,0.))**.33,0.5) - wspdx=sqrt(wspdx*wspdx+vconv*vconv+vsgd*vsgd) - wspdx=max(wspdx,0.1) !0.1 is wmin - rbx=govrth*za*dthvdz/(wspdx*wspdx) !buld rich # - - if (itime == 1) then - rbx=max(rbx,-2.0) - rbx=min(rbx, 2.0) - else - rbx=max(rbx,-4.0) - rbx=min(rbx, 4.0) - endif - - -! visc=(1.32+0.009*(t1d-273.15))*1.e-5 -! kinematic viscosity - - - visc=1.326e-5*(1. + 6.542e-3*t1dc + 8.301e-6*t1dc*t1dc & - - 4.84e-9*t1dc*t1dc*t1dc) - -!compute roughness reynolds number (restar) using default znt -!the GFS option has been removed - - restar=max(ust*znt/visc,0.1) - -! get zt, zq based on the input -! the GFS roughness option and spp_pbl have been removed - - if (snwh > 50. .or. isice == 1) then ! (mm) treat as snow cover - use andreas cover isice =1 - call andreas_2002(znt,visc,ust,zt,zq) - else - if ( present(iz0tlnd) ) then - if ( iz0tlnd .le. 1 ) then - call zilitinkevich_1995(znt,zt,zq,restar,& - ust,karman,1.0,iz0tlnd,0,0.0) - elseif ( iz0tlnd .eq. 2 ) then - call yang_2008(znt,zt,zq,ust,molx,& - qstar,restar,visc) - elseif ( iz0tlnd .eq. 3 ) then - !original mynn in wrf-arw used this form: - call garratt_1992(zt,zq,znt,restar,1.0) - endif - -! the GFS option is removed along with gfs_z0_lnd - - else - - !default to zilitinkevich - call zilitinkevich_1995(znt,zt,zq,restar,& - ust,karman,1.0,0,0,0.0) - endif - endif - - -! --------- -! calculate bulk richardson no. of surface layer, -! according to akb(1976), eq(12). - - gz1oz0= log((za+znt)/znt) - gz1ozt= log((za+znt)/zt) - gz2oz0= log((2.0+znt)/znt) - gz2ozt= log((2.0+znt)/zt) - gz10oz0=log((10.+znt)/znt) -! gz10ozt=log((10.+znt)/zt) - - zratio=znt/zt !need estimate for li et al. - - -! vconv = 0.25*sqrt(g/tskv*pblh(i)*dthvm) -! if(mol.lt.0.) br=amin1(br,0.0) -> check the input mol later -! rmol=-govrth*dthvdz*za*karman - - if (rbx .gt. 0.0) then - - !compute z/l first guess: - call li_etal_2010(zolx,rbx,za/znt,zratio) - !zol=za*karman*g*mol/(thx*max(ust*ust,0.0001)) - zolx=max(zolx,0.0) - zolx=min(zolx,20.) - - - !use pedros iterative function to find z/l - !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt) - !use brute-force method - - zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt) - zolx=max(zolx,0.0) - zolx=min(zolx,20.) - - zolzt = zolx*zt/za ! zt/l - zolz0 = zolx*znt/za ! z0/l - zolza = zolx*(za+znt)/za ! (z+z0/l - zol10 = zolx*(10.+znt)/za ! (10+z0)/l - zol2 = zolx*(2.+znt)/za ! (2+z0)/l - - !compute psim and psih - !call psi_beljaars_holtslag_1991(psim,psih,zol) - !call psi_businger_1971(psim,psih,zol) - !call psi_zilitinkevich_esau_2007(psim,psih,zol) - !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za) - !call psi_cb2005(psim,psih,zolza,zolz0) - - psim=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) - psih=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) - psim10=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) -! psih10=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) - psih2=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt) - - ! 1.0 over monin-obukhov length - - rmolx= zolx/za - - elseif(rbx .eq. 0.) then - !========================================================= - !-----class 3; forced convection/neutral: - !========================================================= - - psim=0.0 - psih=psim - psim10=0. -! psih10=0. - psih2=0. - - zolx =0. - rmolx =0. - - elseif(rbx .lt. 0.)then - !========================================================== - !-----class 4; free convection: - !========================================================== - - !compute z/l first guess: - - call li_etal_2010(zolx,rbx,za/znt,zratio) - - !zol=za*karman*g*mol/(th1d*max(ust_lnd*ust_lnd,0.001)) - - zolx=max(zolx,-20.0) - zolx=min(zolx,0.0) - - - !use pedros iterative function to find z/l - !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt) - !use brute-force method - - zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt) - zolx=max(zolx,-20.0) - zolx=min(zolx,0.0) - - zolzt = zolx*zt/za ! zt/l - zolz0 = zolx*znt/za ! z0/l - zolza = zolx*(za+znt)/za ! (z+z0/l - zol10 = zolx*(10.+znt)/za ! (10+z0)/l - zol2 = zolx*(2.+znt)/za ! (2+z0)/l - - !compute psim and psih - !call psi_hogstrom_1996(psim,psih,zol, zt_lnd, zntstoch_lnd, za) - !call psi_businger_1971(psim,psih,zol) - !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za) - ! use tables - - psim=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) - psih=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) - psim10=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) -! psih10=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) - psih2=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt) - - !---limit psih and psim in the case of thin layers and - !---high roughness. this prevents denominator in fluxes - !---from getting too small - - psih=min(psih,0.9*gz1ozt) - psim=min(psim,0.9*gz1oz0) - psih2=min(psih2,0.9*gz2ozt) - psim10=min(psim10,0.9*gz10oz0) -! psih10=min(psih10,0.9*gz10ozt) - - rmolx = zolx/za - - endif - - ! calculate the resistance: - - psix =max(gz1oz0-psim, 1.0) - psix10=max(gz10oz0-psim10, 1.0) - psit =max(gz1ozt-psih , 1.0) - psit2 =max(gz2ozt-psih2, 1.0) - psiq =max(log((za+zq)/zq)-psih ,1.0) - psiq2 =max(log((2.0+zq)/zq)-psih2 ,1.0) - - !------------------------------------------------------------ - !-----compute the frictional velocity: - !------------------------------------------------------------ - - - ! to prevent oscillations average with old value - -! oldust = ust - - ust=0.5*ust+0.5*karman*wspdx/psix - ust=max(ust,0.005) - -! stress=ust**2 - - !set ustm = ust over land. - -! ustmx=ust - - - !---------------------------------------------------- - !----compute the temperature scale (a.k.a. friction temperature, t*, or mol) - !----and compute the moisture scale (or q*) - !---------------------------------------------------- - - dtg=thvx-tskv - -! oldtst=mol - - molx=karman*dtg/psit/prt !T* - - !t_star = -hfx/(ust*cpm*rho1d) - !t_star = mol - !---------------------------------------------------- - ! dqg=(qvsh-qsfc)*1000. !(kg/kg -> g/kg) - - dqg=(qx-qsfc)*1000. !(kg/kg -> g/kg) - qstar=karman*dqg/psiq/prt - - cm = (karman/psix)*(karman/psix)*wspdx - -! cm = (karman/psix)*(karman/psix) -! ch = (karman/psix)*(karman/psit) - - chs=ust*karman/psit - cqs2=ust*karman/psiq2 - chs2=ust*karman/psit2 - -! u10=ux*psix10/psix -! v10=vx*psix10/psix - - flhcx = rhox*cpm*ust*karman/psit - flqcx = rhox*1.0*ust*karman/psiq - -! ch = flhcx/(cpm*rhox) !same chs - - fmx = psix - fhx = psit - fm10x = psix10 - fh2x =psit2 - -! ustmx = ust - - stressx = ust**2 ! or cm*wind*wind - - end subroutine sfcdif4 - - subroutine zilitinkevich_1995(z_0,zt,zq,restar,ustar,karman,& - & landsea,iz0tlnd2,spp_pbl,rstoch) - - implicit none - real, intent(in) :: z_0,restar,ustar,karman,landsea - integer, optional, intent(in):: iz0tlnd2 - real, intent(out) :: zt,zq - real :: czil !=0.100 in chen et al. (1997) - !=0.075 in zilitinkevich (1995) - !=0.500 in lemone et al. (2008) - integer, intent(in) :: spp_pbl - real, intent(in) :: rstoch - - - if (landsea-1.5 .gt. 0) then !water - - !this is based on zilitinkevich, grachev, and fairall (2001; - !their equations 15 and 16). - if (restar .lt. 0.1) then - zt = z_0*exp(karman*2.0) - zt = min( zt, 6.0e-5) - zt = max( zt, 2.0e-9) - zq = z_0*exp(karman*3.0) - zq = min( zq, 6.0e-5) - zq = max( zq, 2.0e-9) - else - zt = z_0*exp(-karman*(4.0*sqrt(restar)-3.2)) - zt = min( zt, 6.0e-5) - zt = max( zt, 2.0e-9) - zq = z_0*exp(-karman*(4.0*sqrt(restar)-4.2)) - zq = min( zt, 6.0e-5) - zq = max( zt, 2.0e-9) - endif - - else !land - - !option to modify czil according to chen & zhang, 2009 - if ( iz0tlnd2 .eq. 1 ) then - czil = 10.0 ** ( -0.40 * ( z_0 / 0.07 ) ) - else - czil = 0.085 !0.075 !0.10 - end if - - zt = z_0*exp(-karman*czil*sqrt(restar)) - zt = min( zt, 0.75*z_0) - - zq = z_0*exp(-karman*czil*sqrt(restar)) - zq = min( zq, 0.75*z_0) - -! stochastically perturb thermal and moisture roughness length. -! currently set to half the amplitude: - if (spp_pbl==1) then - zt = zt + zt * 0.5 * rstoch - zt = max(zt, 0.0001) - zq = zt - endif - - endif - - return - - end subroutine zilitinkevich_1995 - -!!data. the formula for land uses a constant ratio (z_0/7.4) taken -!!from garratt (1992). - subroutine garratt_1992(zt,zq,z_0,ren,landsea) - - implicit none - real, intent(in) :: ren, z_0,landsea - real, intent(out) :: zt,zq - real :: rq - real, parameter :: e=2.71828183 - - if (landsea-1.5 .gt. 0) then !water - - zt = z_0*exp(2.0 - (2.48*(ren**0.25))) - zq = z_0*exp(2.0 - (2.28*(ren**0.25))) - - zq = min( zq, 5.5e-5) - zq = max( zq, 2.0e-9) - zt = min( zt, 5.5e-5) - zt = max( zt, 2.0e-9) !same lower limit as ecmwf - else !land - zq = z_0/(e**2.) !taken from garratt (1980,1992) - zt = zq - endif - - return - - end subroutine garratt_1992 -!-------------------------------------------------------------------- -!>\ingroup mynn_sfc -!> this is a modified version of yang et al (2002 qjrms, 2008 jamc) -!! and chen et al (2010, j of hydromet). although it was originally -!! designed for arid regions with bare soil, it is modified -!! here to perform over a broader spectrum of vegetation. -!! -!!the original formulation relates the thermal roughness length (zt) -!!to u* and t*: -!! -!! zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar)**0.25)) -!! -!!where ht = renc*visc/ustar and the critical reynolds number -!!(renc) = 70. beta was originally = 10 (2002 paper) but was revised -!!to 7.2 (in 2008 paper). their form typically varies the -!!ratio z0/zt by a few orders of magnitude (1-1e4). -!! -!!this modified form uses beta = 1.5 and a variable renc (function of z_0), -!!so zt generally varies similarly to the zilitinkevich form (with czil = 0.1) -!!for very small or negative surface heat fluxes but can become close to the -!!zilitinkevich with czil = 0.2 for very large hfx (large negative t*). -!!also, the exponent (0.25) on tstar was changed to 1.0, since we found -!!zt was reduced too much for low-moderate positive heat fluxes. -!! -!!this should only be used over land! - subroutine yang_2008(z_0,zt,zq,ustar,tstar,qst,ren,visc) - - implicit none - real, intent(in) :: z_0, ren, ustar, tstar, qst, visc - real :: ht, &! roughness height at critical reynolds number - tstar2, &! bounded t*, forced to be non-positive - qstar2, &! bounded q*, forced to be non-positive - z_02, &! bounded z_0 for variable renc2 calc - renc2 ! variable renc, function of z_0 - real, intent(out) :: zt,zq - real, parameter :: renc=300., & !old constant renc - beta=1.5, & !important for diurnal variation - m=170., & !slope for renc2 function - b=691. !y-intercept for renc2 function - - z_02 = min(z_0,0.5) - z_02 = max(z_02,0.04) - renc2= b + m*log(z_02) - ht = renc2*visc/max(ustar,0.01) - tstar2 = min(tstar, 0.0) - qstar2 = min(qst,0.0) - - zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar2)**1.0)) - zq = ht * exp(-beta*(ustar**0.5)*(abs(qstar2)**1.0)) - !zq = zt - - zt = min(zt, z_0/2.0) - zq = min(zq, z_0/2.0) - - return - - end subroutine yang_2008 - -!>\ingroup mynn_sfc -!> this is taken from andreas (2002; j. of hydromet) and -!! andreas et al. (2005; blm). -!! -!! this should only be used over snow/ice! - subroutine andreas_2002(z_0,bvisc,ustar,zt,zq) - - implicit none - real, intent(in) :: z_0, bvisc, ustar - real, intent(out) :: zt, zq - real :: ren2, zntsno - - real, parameter :: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, & - bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, & - bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183 - - real, parameter :: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, & - bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, & - bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180 - - !calculate zo for snow (andreas et al. 2005, blm) - zntsno = 0.135*bvisc/ustar + & - (0.035*(ustar*ustar)/9.8) * & - (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.) - ren2 = ustar*zntsno/bvisc - - ! make sure that re is not outside of the range of validity - ! for using their equations - if (ren2 .gt. 1000.) ren2 = 1000. - - if (ren2 .le. 0.135) then - - zt = zntsno*exp(bt0_s + bt1_s*log(ren2) + bt2_s*log(ren2)**2) - zq = zntsno*exp(bq0_s + bq1_s*log(ren2) + bq2_s*log(ren2)**2) - - else if (ren2 .gt. 0.135 .and. ren2 .lt. 2.5) then - - zt = zntsno*exp(bt0_t + bt1_t*log(ren2) + bt2_t*log(ren2)**2) - zq = zntsno*exp(bq0_t + bq1_t*log(ren2) + bq2_t*log(ren2)**2) - - else - - zt = zntsno*exp(bt0_r + bt1_r*log(ren2) + bt2_r*log(ren2)**2) - zq = zntsno*exp(bq0_r + bq1_r*log(ren2) + bq2_r*log(ren2)**2) - - endif - - return - - end subroutine andreas_2002 -!-------------------------------------------------------------------- -!>\ingroup mynn_sfc -!! this subroutine returns a more robust z/l that best matches -!! the z/l from hogstrom (1996) for unstable conditions and beljaars -!! and holtslag (1991) for stable conditions. - subroutine li_etal_2010(zl, rib, zaz0, z0zt) - - implicit none - real, intent(out) :: zl - real, intent(in) :: rib, zaz0, z0zt - real :: alfa, beta, zaz02, z0zt2 - real, parameter :: au11=0.045, bu11=0.003, bu12=0.0059, & - &bu21=-0.0828, bu22=0.8845, bu31=0.1739, & - &bu32=-0.9213, bu33=-0.1057 - real, parameter :: aw11=0.5738, aw12=-0.4399, aw21=-4.901,& - &aw22=52.50, bw11=-0.0539, bw12=1.540, & - &bw21=-0.669, bw22=-3.282 - real, parameter :: as11=0.7529, as21=14.94, bs11=0.1569,& - &bs21=-0.3091, bs22=-1.303 - - !set limits according to li et al (2010), p 157. - zaz02=zaz0 - if (zaz0 .lt. 100.0) zaz02=100. - if (zaz0 .gt. 100000.0) zaz02=100000. - - !set more limits according to li et al (2010) - z0zt2=z0zt - if (z0zt .lt. 0.5) z0zt2=0.5 - if (z0zt .gt. 100.0) z0zt2=100. - - alfa = log(zaz02) - beta = log(z0zt2) - - if (rib .le. 0.0) then - zl = au11*alfa*rib**2 + ( & - & (bu11*beta + bu12)*alfa**2 + & - & (bu21*beta + bu22)*alfa + & - & (bu31*beta**2 + bu32*beta + bu33))*rib - !if(zl .lt. -15 .or. zl .gt. 0.)print*,"violation rib<0:",zl - zl = max(zl,-15.) !limits set according to li et al (2010) - zl = min(zl,0.) !figure 1. - elseif (rib .gt. 0.0 .and. rib .le. 0.2) then - zl = ((aw11*beta + aw12)*alfa + & - & (aw21*beta + aw22))*rib**2 + & - & ((bw11*beta + bw12)*alfa + & - & (bw21*beta + bw22))*rib - !if(zl .lt. 0 .or. zl .gt. 4)print*,"violation 00.2:",zl - zl = min(zl,20.) !limits according to li et al (2010), thier - !figue 1c. - zl = max(zl,1.) - endif - - return - - end subroutine li_etal_2010 -!------------------------------------------------------------------- - real function zolri(ri,za,z0,zt,zol1,psi_opt) - - ! this iterative algorithm was taken from the revised surface layer - ! scheme in wrf-arw, written by pedro jimenez and jimy dudhia and - ! summarized in jimenez et al. (2012, mwr). this function was adapted - ! to input the thermal roughness length, zt, (as well as z0) and use initial - ! estimate of z/l. - - implicit none - real, intent(in) :: ri,za,z0,zt,zol1 - integer, intent(in) :: psi_opt - real :: x1,x2,fx1,fx2 - integer :: n - integer, parameter :: nmax = 20 - !real, dimension(nmax):: zlhux -! real :: zolri2 - - if (ri.lt.0.)then - x1=zol1 - 0.02 !-5. - x2=0. - else - x1=0. - x2=zol1 + 0.02 !5. - endif - - n=1 - fx1=zolri2(x1,ri,za,z0,zt,psi_opt) - fx2=zolri2(x2,ri,za,z0,zt,psi_opt) - - do while (abs(x1 - x2) > 0.01 .and. n < nmax) - if(abs(fx2).lt.abs(fx1))then - x1=x1-fx1/(fx2-fx1)*(x2-x1) - fx1=zolri2(x1,ri,za,z0,zt,psi_opt) - zolri=x1 - else - x2=x2-fx2/(fx2-fx1)*(x2-x1) - fx2=zolri2(x2,ri,za,z0,zt,psi_opt) - zolri=x2 - endif - n=n+1 - !print*," n=",n," x1=",x1," x2=",x2 - !zlhux(n)=zolri - enddo - - if (n==nmax .and. abs(x1 - x2) >= 0.01) then - !if convergence fails, use approximate values: - call li_etal_2010(zolri, ri, za/z0, z0/zt) - !zlhux(n)=zolri - !print*,"iter fail, n=",n," ri=",ri," z0=",z0 - else - !print*,"success,n=",n," ri=",ri," z0=",z0 - endif - - return - end function -!------------------------------------------------------------------- - real function zolri2(zol2,ri2,za,z0,zt,psi_opt) - - ! input: ================================= - ! zol2 - estimated z/l - ! ri2 - calculated bulk richardson number - ! za - 1/2 depth of first model layer - ! z0 - aerodynamic roughness length - ! zt - thermal roughness length - ! output: ================================ - ! zolri2 - delta ri - - implicit none - integer, intent(in) :: psi_opt - real, intent(in) :: ri2,za,z0,zt - real, intent(inout) :: zol2 - real :: zol20,zol3,psim1,psih1,psix2,psit2,zolt - -! real :: psih_unstable,psim_unstable,psih_stable, psim_stable - - if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 - - zol20=zol2*z0/za ! z0/l - zol3=zol2+zol20 ! (z+z0)/l - zolt=zol2*zt/za ! zt/l - - if (ri2.lt.0) then - !psix2=log((za+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) - !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) - psit2=max(log((za+z0)/zt)-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) - psix2=max(log((za+z0)/z0)-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)),1.0) - else - !psix2=log((za+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) - !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) - psit2=max(log((za+z0)/zt)-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) - psix2=max(log((za+z0)/z0)-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)),1.0) - endif - - zolri2=zol2*psit2/psix2**2 - ri2 - !print*," target ri=",ri2," est ri=",zol2*psit2/psix2**2 - - return - end function -!==================================================================== - - real function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) - - ! this iterative algorithm to compute z/l from bulk-ri - - implicit none - real, intent(in) :: ri,za,z0,zt,logz0,logzt - integer, intent(in) :: psi_opt - real, intent(inout) :: zol1 - real :: zol20,zol3,zolt,zolold - integer :: n - integer, parameter :: nmax = 20 - real, dimension(nmax):: zlhux - real :: psit2,psix2 - -! real :: psim_unstable, psim_stable -! real :: psih_unstable, psih_stable - - !print*,"+++++++incoming: z/l=",zol1," ri=",ri - if (zol1*ri .lt. 0.) then - !print*,"begin: wrong quadrants: z/l=",zol1," ri=",ri - zol1=0. - endif - - if (ri .lt. 0.) then - zolold=-99999. - zolrib=-66666. - else - zolold=99999. - zolrib=66666. - endif - n=1 - - do while (abs(zolold - zolrib) > 0.01 .and. n < nmax) - - if(n==1)then - zolold=zol1 - else - zolold=zolrib - endif - zol20=zolold*z0/za ! z0/l - zol3=zolold+zol20 ! (z+z0)/l - zolt=zolold*zt/za ! zt/l - !print*,"z0/l=",zol20," (z+z0)/l=",zol3," zt/l=",zolt - if (ri.lt.0) then - !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) - !psit2=log((za+z0)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) - psit2=max(logzt-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) - psix2=max(logz0-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)), 1.0) - else - !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) - !psit2=log((za+z0)/zt)-(psih_stable(zol3)-psih_stable(zol20)) - psit2=max(logzt-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) - psix2=max(logz0-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)), 1.0) - endif - !print*,"n=",n," psit2=",psit2," psix2=",psix2 - zolrib=ri*psix2**2/psit2 - zlhux(n)=zolrib - n=n+1 - enddo - - if (n==nmax .and. abs(zolold - zolrib) > 0.01 ) then - !print*,"iter fail, n=",n," ri=",ri," z/l=",zolri - !if convergence fails, use approximate values: - call li_etal_2010(zolrib, ri, za/z0, z0/zt) - zlhux(n)=zolrib - !print*,"failed, n=",n," ri=",ri," z0=",z0 - !print*,"z/l=",zlhux(1:nmax) - else - !if(zolrib*ri .lt. 0.) then - ! !print*,"end: wrong quadrants: z/l=",zolrib," ri=",ri - ! !call li_etal_2010(zolrib, ri, za/z0, z0/zt) - !endif - !print*,"success,n=",n," ri=",ri," z0=",z0 - endif - - return - end function -!==================================================================== - - subroutine psi_init(psi_opt,errmsg,errflg) - - integer :: n,psi_opt - real :: zolf - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - if (psi_opt == 0) then - do n=0,1000 - ! stable function tables - zolf = float(n)*0.01 - psim_stab(n)=psim_stable_full(zolf) - psih_stab(n)=psih_stable_full(zolf) - - ! unstable function tables - zolf = -float(n)*0.01 - psim_unstab(n)=psim_unstable_full(zolf) - psih_unstab(n)=psih_unstable_full(zolf) - enddo - else - do n=0,1000 - ! stable function tables - zolf = float(n)*0.01 - psim_stab(n)=psim_stable_full_gfs(zolf) - psih_stab(n)=psih_stable_full_gfs(zolf) - - ! unstable function tables - zolf = -float(n)*0.01 - psim_unstab(n)=psim_unstable_full_gfs(zolf) - psih_unstab(n)=psih_unstable_full_gfs(zolf) - enddo - endif - - !simple test to see if initialization worked: - if (psim_stab(1) < 0. .and. psih_stab(1) < 0. .and. & - psim_unstab(1) > 0. .and. psih_unstab(1) > 0.) then - errmsg = 'in mynn sfc, psi tables have been initialized' - errflg = 0 - else - errmsg = 'error in mynn sfc: problem initializing psi tables' - errflg = 1 - endif - - end subroutine psi_init -! ================================================================== -! ... integrated similarity functions from mynn... -! -!>\ingroup mynn_sfc - real function psim_stable_full(zolf) - real :: zolf - - !psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) - psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**0.4) - - return - end function - -!>\ingroup mynn_sfc - real function psih_stable_full(zolf) - real :: zolf - - !psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) - psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**0.9090909090909090909) - - return - end function - -!>\ingroup mynn_sfc - real function psim_unstable_full(zolf) - real :: zolf,x,ym,psimc,psimk - - x=(1.-16.*zolf)**.25 - !psimk=2*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan(1.) - psimk=2.*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan1 - - ym=(1.-10.*zolf)**onethird - !psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*atan((2.*ym+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.) - psimc=1.5*log((ym**2 + ym+1.)*onethird)-sqrt3*atan((2.*ym+1)/sqrt3)+4.*atan1/sqrt3 - - psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) - - return - end function - -!>\ingroup mynn_sfc - real function psih_unstable_full(zolf) - real :: zolf,y,yh,psihc,psihk - - y=(1.-16.*zolf)**.5 - !psihk=2.*log((1+y)/2.) - psihk=2.*log((1+y)*0.5) - - yh=(1.-34.*zolf)**onethird - !psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*atan((2.*yh+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.) - psihc=1.5*log((yh**2.+yh+1.)*onethird)-sqrt3*atan((2.*yh+1)/sqrt3)+4.*atan1/sqrt3 - - psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2) - - return - end function - -! ================================================================== -! ... integrated similarity functions from gfs... -! - real function psim_stable_full_gfs(zolf) - real :: zolf - real, parameter :: alpha4 = 20. - real :: aa - - aa = sqrt(1. + alpha4 * zolf) - psim_stable_full_gfs = -1.*aa + log(aa + 1.) - - return - end function - - real function psih_stable_full_gfs(zolf) - real :: zolf - real, parameter :: alpha4 = 20. - real :: bb - - bb = sqrt(1. + alpha4 * zolf) - psih_stable_full_gfs = -1.*bb + log(bb + 1.) - - return - end function - - real function psim_unstable_full_gfs(zolf) - real :: zolf - real :: hl1,tem1 - real, parameter :: a0=-3.975, a1=12.32, & - b1=-7.755, b2=6.041 - - if (zolf .ge. -0.5) then - hl1 = zolf - psim_unstable_full_gfs = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) - else - hl1 = -zolf - tem1 = 1.0 / sqrt(hl1) - psim_unstable_full_gfs = log(hl1) + 2. * sqrt(tem1) - .8776 - end if - - return - end function - - real function psih_unstable_full_gfs(zolf) - real :: zolf - real :: hl1,tem1 - real, parameter :: a0p=-7.941, a1p=24.75, & - b1p=-8.705, b2p=7.899 - - if (zolf .ge. -0.5) then - hl1 = zolf - psih_unstable_full_gfs = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) - else - hl1 = -zolf - tem1 = 1.0 / sqrt(hl1) - psih_unstable_full_gfs = log(hl1) + .5 * tem1 + 1.386 - end if - - return - end function - -!================================================================= -! look-up table functions - or, if beyond -10 < z/l < 10, recalculate -!================================================================= - real function psim_stable(zolf,psi_opt) - integer :: nzol,psi_opt - real :: rzol,zolf - - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) - else - if (psi_opt == 0) then - psim_stable = psim_stable_full(zolf) - else - psim_stable = psim_stable_full_gfs(zolf) - endif - endif - - return - end function - - real function psih_stable(zolf,psi_opt) - integer :: nzol,psi_opt - real :: rzol,zolf - - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) - else - if (psi_opt == 0) then - psih_stable = psih_stable_full(zolf) - else - psih_stable = psih_stable_full_gfs(zolf) - endif - endif - - return - end function - - real function psim_unstable(zolf,psi_opt) - integer :: nzol,psi_opt - real :: rzol,zolf - - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) - else - if (psi_opt == 0) then - psim_unstable = psim_unstable_full(zolf) - else - psim_unstable = psim_unstable_full_gfs(zolf) - endif - endif - - return - end function - - real function psih_unstable(zolf,psi_opt) - integer :: nzol,psi_opt - real :: rzol,zolf - - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) - else - if (psi_opt == 0) then - psih_unstable = psih_unstable_full(zolf) - else - psih_unstable = psih_unstable_full_gfs(zolf) - endif - endif - - return - end function -!======================================================================== end module module_sf_noahmplsm diff --git a/physics/sfc_noahmp_drv.F90 b/physics/sfc_noahmp_drv.F90 index ccd9f80f6..0ebcbd615 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/sfc_noahmp_drv.F90 @@ -11,12 +11,8 @@ !> This module contains the CCPP-compliant NoahMP land surface model driver. module noahmpdrv - use module_sf_noahmplsm - implicit none - integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS - private public :: noahmpdrv_init, noahmpdrv_run, noahmpdrv_finalize @@ -31,7 +27,6 @@ module noahmpdrv !! subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & nlunit, pores, resid, & - do_mynnsfclay,do_mynnedmf, & errmsg, errflg) use machine, only: kind_phys @@ -45,10 +40,6 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & real (kind=kind_phys), dimension(:), intent(out) :: pores, resid - logical, intent(in) :: do_mynnsfclay - logical, intent(in) :: do_mynnedmf - - character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -77,31 +68,9 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & return end if - if (.not. do_mynnsfclay .and. do_mynnedmf) then - errmsg = 'Problem : do_mynnsfclay = .false.' // & - 'but mynnpbl is .true.. Exiting ...' - errflg = 1 - return - end if - - if ( do_mynnsfclay .and. .not. do_mynnedmf) then - errmsg = 'Problem : do_mynnsfclay = .true.' // & - 'but mynnpbl is .false.. Exiting ...' - errflg = 1 - return - end if - - !--- initialize soil vegetation call set_soilveg(me, isot, ivegsrc, nlunit) - - ! initialize psih and psim - - if ( do_mynnsfclay ) then - call psi_init(psi_opt,errmsg,errflg) - endif - pores (:) = maxsmc (:) resid (:) = drysmc (:) @@ -138,7 +107,7 @@ subroutine noahmpdrv_run & ! --- inputs: ( im, km, lsnowl, itime, ps, u1, v1, t1, q1, soiltyp, & vegtype, sigmaf, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & - prsl1, prslk1, prslki, prsik1, zf,pblh, dry, wind, slopetyp, & + prsl1, prslk1, prslki, prsik1, zf, dry, wind, slopetyp, & shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & @@ -151,7 +120,6 @@ subroutine noahmpdrv_run & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & canopy, trans, tsurf, zorl, & rb1, fm1, fh1, ustar1, stress1, fm101, fh21, & - rmol1,flhc1,flqc1,do_mynnsfclay, & ! --- Noah MP specific @@ -172,7 +140,7 @@ subroutine noahmpdrv_run & use funcphys, only : fpvs use sfc_diff, only : stability -! use module_sf_noahmplsm + use module_sf_noahmplsm use module_sf_noahmp_glacier use noahmp_tables, only : isice_table, co2_table, o2_table, & isurban_table, smcref_table, smcdry_table, & @@ -192,8 +160,6 @@ subroutine noahmpdrv_run & integer, parameter :: nsoil = 4 ! hardwired to Noah integer, parameter :: nsnow = 3 ! max. snow layers - integer, parameter :: iz0tlnd = 0 ! z0t treatment option - real(kind=kind_phys), save :: zsoil(nsoil) data zsoil / -0.1, -0.4, -1.0, -2.0 / @@ -227,15 +193,6 @@ subroutine noahmpdrv_run & real(kind=kind_phys), dimension(:) , intent(in) :: prsik1 ! Exner function at the ground surfac real(kind=kind_phys), dimension(:) , intent(in) :: zf ! height of bottom layer [m] - - logical , intent(in) :: do_mynnsfclay !flag for MYNN sfc layer scheme - - real(kind=kind_phys), dimension(:) , intent(in) :: pblh ! height of pbl - real(kind=kind_phys), dimension(:) , intent(inout) :: rmol1 ! - real(kind=kind_phys), dimension(:) , intent(inout) :: flhc1 ! - real(kind=kind_phys), dimension(:) , intent(inout) :: flqc1 ! - - logical , dimension(:) , intent(in) :: dry ! = T if a point with any land real(kind=kind_phys), dimension(:) , intent(in) :: wind ! wind speed [m/s] integer , dimension(:) , intent(in) :: slopetyp ! surface slope classification @@ -548,17 +505,6 @@ subroutine noahmpdrv_run & real (kind=kind_phys) :: prsik1x ! in exner function real (kind=kind_phys) :: prslk1x ! in exner function - real (kind=kind_phys) :: ch2 - real (kind=kind_phys) :: cq2 - real (kind=kind_phys) :: qfx - real (kind=kind_phys) :: wspd1 ! wind speed with all components - real (kind=kind_phys) :: pblhx ! height of pbl - integer :: mnice - - real (kind=kind_phys) :: rah_total ! - real (kind=kind_phys) :: cah_total ! - - ! ! --- local variable ! @@ -648,8 +594,6 @@ subroutine noahmpdrv_run & vwind_forcing = v1(i) area_grid = garea(i) - pblhx = pblh(i) - prslkix = prslki(i) prsik1x = prsik1(i) prslk1x = prslk1(i) @@ -738,13 +682,6 @@ subroutine noahmpdrv_run & snow_ice_frac_old(k) = snow_level_ice(k) /(snow_level_ice(k)+snow_level_liquid(k)) end do - - if (snow_depth .gt. 0.1 .or. vegetation_category == isice_table ) then - mnice = 1 - else - mnice = 0 - endif - ! ! --- some outputs for atm model? ! @@ -788,8 +725,7 @@ subroutine noahmpdrv_run & spec_humidity_forcing,sw_radiation_forcing ,precipitation_forcing,radiation_lw_forcing , & temperature_soil_bot ,forcing_height ,snow_ice_frac_old ,zsoil , & thsfc_loc ,prslkix ,prsik1x ,prslk1x , & - air_pressure_surface ,pblhx ,iz0tlnd ,itime , & - vegetation_frac ,area_grid ,psi_opt , & + vegetation_frac ,area_grid , & snowfall ,snow_water_equiv_old ,snow_albedo_old , & cm_noahmp ,ch_noahmp ,snow_levels ,snow_water_equiv , & soil_moisture_vol ,interface_depth ,snow_depth ,snow_level_ice , & @@ -868,8 +804,6 @@ subroutine noahmpdrv_run & spec_humidity_forcing ,area_grid ,cloud_water_forcing , & sw_radiation_forcing ,radiation_lw_forcing ,thsfc_loc , & prslkix ,prsik1x ,prslk1x , & - pblhx ,iz0tlnd ,itime , & - psi_opt , & precip_convective , & precip_non_convective ,precip_sh_convective ,precip_snow , & precip_graupel ,precip_hail ,temperature_soil_bot , & @@ -989,7 +923,7 @@ subroutine noahmpdrv_run & snowc (i) = snow_cover_fraction sncovr1 (i) = snow_cover_fraction -! qsurf (i) = spec_humidity_surface + qsurf (i) = spec_humidity_surface tsurf (i) = tskin(i) tvxy (i) = temperature_leaf @@ -1052,49 +986,11 @@ subroutine noahmpdrv_run & zvfun(i) = sqrt(tem1 * tem2) gdx=sqrt(garea(i)) - if ( .not. do_mynnsfclay) then !GFS sfcdiff - call stability & (zf(i), zvfun(i), gdx, virtual_temperature, vptemp,wind(i), z0_total, z0h_total, & tvs1, con_g, thsfc_loc, & rb1(i), fm1(i), fh1(i), fm101(i), fh21(i), cm(i), ch(i), stress1(i), ustar1(i)) - rmol1(i) = undefined !not used in GFS sfcdif -> to satsify output - flhc1(i) = undefined - flqc1(i) = undefined - - rah_total = max(1.0,1.0/( ch(i)*wind(i)) ) - cah_total = density * con_cp /rah_total -! tskin(i) = sensible_heat_total/cah_total + temperature_forcing ! test to use combined ch and SH to backout Ts - - ch(i) = ch_vegetated * vegetation_frac + ch_bare_ground*(1.0-vegetation_frac) - - else ! MYNN - note the GFS option is the same as sfcdif3; so removed. - - qfx = evap(i) / con_hvap ! use flux from output - - call sfcdif4(i_location ,j_location ,uwind_forcing ,vwind_forcing , & - temperature_forcing, air_pressure_forcing ,air_pressure_surface , & - pblhx,gdx,z0_total,itime,snwdph(i),mnice,psi_opt,surface_temperature, & - spec_humidity_forcing,forcing_height,iz0tlnd,spec_humidity_surface,& - sensible_heat_total,qfx,cm(i),ch(i),ch2,cq2,rmol1(i),ustar1(i), & - rb1(i),fm1(i),fh1(i),stress1(i),fm101(i),fh21(i),wspd1,flhc1(i), & - flqc1(i) ) - - ch(i)=ch(i)/wspd1 - cm(i)=cm(i)/wspd1 - - ch(i) = ch_vegetated * vegetation_frac + ch_bare_ground*(1.0-vegetation_frac) - - rah_total = max(1.0,1.0/( ch(i)*wind(i)) ) - cah_total = density * con_cp /rah_total - -! tskin(i) = sensible_heat_total/cah_total + temperature_forcing ! - - endif - - - cmxy(i) = cm(i) chxy(i) = ch(i) @@ -1102,7 +998,7 @@ subroutine noahmpdrv_run & cmm (i) = cmxy(i) * wind(i) snwdph (i) = snow_depth * 1000.0 ! convert from m to mm; wait after the stability call - qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) +! qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) ! ! --- change units for output diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 9ad9092ec..1246fa1b0 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -65,20 +65,6 @@ type = real intent = out kind = kind_phys -[do_mynnsfclay] - standard_name = flag_for_mellor_yamada_nakanishi_niino_surface_layer_scheme - long_name = flag to activate MYNN surface layer - units = flag - dimensions = () - type = logical - 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 [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -285,14 +271,6 @@ type = real kind = kind_phys intent = in -[pblh] - standard_name = atmosphere_boundary_layer_thickness - long_name = PBL thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [dry] standard_name = flag_nonzero_land_surface_fraction long_name = flag indicating presence of some land surface area fraction @@ -763,37 +741,6 @@ type = real kind = kind_phys intent = inout -[rmol1] - 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 = inout -[flhc1] - standard_name = surface_exchange_coefficient_for_heat - long_name = surface exchange coefficient for heat - units = W m-2 K-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[flqc1] - standard_name = surface_exchange_coefficient_for_moisture - long_name = surface exchange coefficient for moisture - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[do_mynnsfclay] - standard_name = flag_for_mellor_yamada_nakanishi_niino_surface_layer_scheme - long_name = flag to activate MYNN surface layer - units = flag - dimensions = () - type = logical - intent = in [snowxy] standard_name = number_of_snow_layers long_name = number of snow layers From 9b783f400f656f981ce435f8cb988c18ab5682df Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Fri, 25 Mar 2022 22:07:11 +0000 Subject: [PATCH 141/217] Bug fix for COARE3.5 (not used by default) and move some parameters to namelist options --- physics/module_MYNNSFC_wrapper.F90 | 31 ++++++++++------------------- physics/module_MYNNSFC_wrapper.meta | 28 ++++++++++++++++++++++++++ physics/module_sf_mynn.F90 | 21 +++++++++---------- 3 files changed, 49 insertions(+), 31 deletions(-) diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index 150a66472..52a33f555 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -62,6 +62,9 @@ SUBROUTINE mynnsfc_wrapper_run( & & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & !intent(in) & redrag,sfc_z0_type, & !intent(in) + & isftcflx,iz0tlnd, & !intent(in) + & sfclay_compute_flux, & !intent(in) + & sfclay_compute_diag, & !intent(in) & delt,dx, & & u, v, t3d, qvsh, qc, prsl, phii, & & exner, ps, PBLH, slmsk, & @@ -98,19 +101,6 @@ SUBROUTINE mynnsfc_wrapper_run( & ! should be moved to inside the mynn: use machine , only : kind_phys -! use physcons, only : cp => con_cp, & -! & g => con_g, & -! & r_d => con_rd, & -! & r_v => con_rv, & -! & cpv => con_cvap, & -! & cliq => con_cliq, & -! & Cice => con_csol, & -! & rcp => con_rocp, & -! & XLV => con_hvap, & -! & XLF => con_hfus, & -! & EP_1 => con_fvirt, & -! & EP_2 => con_eps - ! USE module_sf_mynn, only : SFCLAY_mynn !tgs - info on iterations: ! flag_iter- logical, execution or not (im) @@ -143,11 +133,9 @@ SUBROUTINE mynnsfc_wrapper_run( & integer, intent(out) :: errflg !MISC CONFIGURATION OPTIONS - INTEGER, PARAMETER :: & - & isftcflx = 0, & !control: 0 - & iz0tlnd = 0, & !control: 0 - & isfflx = 1 - + INTEGER, PARAMETER :: isfflx = 1 + logical, intent(in) :: sfclay_compute_flux,sfclay_compute_diag + integer, intent(in) :: isftcflx,iz0tlnd integer, intent(in) :: im, levs integer, intent(in) :: iter, itimestep, lsm, lsm_ruc logical, dimension(:), intent(in) :: flag_iter @@ -311,9 +299,10 @@ SUBROUTINE mynnsfc_wrapper_run( & EP1=ep_1,EP2=ep_2,KARMAN=karman, & ISFFLX=isfflx,isftcflx=isftcflx,LSM=lsm,LSM_RUC=lsm_ruc, & iz0tlnd=iz0tlnd,psi_opt=psi_opt, & - & sigmaf=sigmaf,vegtype=vegtype,shdmax=shdmax,ivegsrc=ivegsrc, & !intent(in) - & z0pert=z0pert,ztpert=ztpert, & !intent(in) - & redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) + compute_flux=sfclay_compute_flux,compute_diag=sfclay_compute_diag,& + sigmaf=sigmaf,vegtype=vegtype,shdmax=shdmax,ivegsrc=ivegsrc, & !intent(in) + z0pert=z0pert,ztpert=ztpert, & !intent(in) + redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) itimestep=itimestep,iter=iter,flag_iter=flag_iter, & wet=wet, dry=dry, icy=icy, & !intent(in) tskin_wat=tskin_wat, tskin_lnd=tskin_lnd, tskin_ice=tskin_ice, & !intent(in) diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index 4e73504d7..5d30d71f3 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -157,6 +157,34 @@ dimensions = () type = integer intent = in +[isftcflx] + standard_name = flag_for_thermal_roughness_lengths_over_water_in_mynnsfclay + long_name = flag for thermal roughness lengths over water in mynnsfclay + units = flag + dimensions = () + type = integer + intent = in +[iz0tlnd] + standard_name = flag_for_thermal_roughness_lengths_over_land_in_mynnsfclay + long_name = flag for thermal roughness lengths over land in mynnsfclay + units = flag + dimensions = () + type = integer + intent = in +[sfclay_compute_flux] + standard_name = flag_for_computing_surface_scalar_fluxes_in_mynnsfclay + long_name = flag for computing surface scalar fluxes in mynnsfclay + units = flag + dimensions = () + type = logical + intent = in +[sfclay_compute_diag] + standard_name = flag_for_computing_surface_diagnostics_in_mynnsfclay + long_name = flag for computing surface diagnostics in mynnsfclay + units = flag + dimensions = () + type = logical + intent = in [delt] standard_name = timestep_for_physics long_name = time step for physics diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 65e83c93d..31335d3a9 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -111,10 +111,6 @@ MODULE module_sf_mynn INTEGER, PARAMETER :: debug_code = 0 !0: no extra ouput !1: check input !2: everything - heavy I/O - LOGICAL, PARAMETER :: compute_diag = .false. - LOGICAL, PARAMETER :: compute_flux = .true. !shouldn't need compute - ! these in FV3. They will be written over anyway. - ! Computing the fluxes here is leftover from the WRF world. REAL, DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, & psih_stab,psih_unstab @@ -132,10 +128,11 @@ SUBROUTINE SFCLAY_mynn( & CP,G,ROVCP,R,XLV, & !in SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & !in ISFFLX,isftcflx,lsm,lsm_ruc, & !in + compute_flux,compute_diag, & !in iz0tlnd,psi_opt, & !in - & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) - & z0pert,ztpert, & !intent(in) - & redrag,sfc_z0_type, & !intent(in) + sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) + z0pert,ztpert, & !intent(in) + redrag,sfc_z0_type, & !intent(in) itimestep,iter,flag_iter, & !in wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) @@ -273,8 +270,9 @@ SUBROUTINE SFCLAY_mynn( & REAL, INTENT(IN) :: CP,G,ROVCP,R,XLV !,DX !NAMELIST/CONFIGURATION OPTIONS: INTEGER, INTENT(IN) :: ISFFLX, LSM, LSM_RUC - INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt + INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND + INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt + logical, intent(in) :: compute_flux,compute_diag integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -441,6 +439,7 @@ SUBROUTINE SFCLAY_mynn( & CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & EP1,EP2,KARMAN, & ISFFLX,isftcflx,iz0tlnd,psi_opt, & + compute_flux,compute_diag, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) @@ -488,6 +487,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & EP1,EP2,KARMAN, & ISFFLX,isftcflx,iz0tlnd,psi_opt, & + compute_flux,compute_diag, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) @@ -543,6 +543,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !----------------------------- INTEGER, INTENT(IN) :: ISFFLX INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND + logical, intent(in) :: compute_flux,compute_diag INTEGER, INTENT(IN) :: spp_sfc, psi_opt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean @@ -2418,7 +2419,7 @@ SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu) REAL, INTENT(IN) :: ustar, visc, wsp10, zu REAL, INTENT(OUT) :: Z_0 REAL, PARAMETER :: G=9.81 - REAL, PARAMETER :: m=0.017, b=-0.005 + REAL, PARAMETER :: m=0.0017, b=-0.005 REAL :: CZC ! variable charnock "constant" REAL :: wsp10m ! logarithmically calculated 10 m From 8f3c084264d49da54b7f4a7e0e202d966232e22a Mon Sep 17 00:00:00 2001 From: helin wei Date: Sat, 26 Mar 2022 03:19:48 +0000 Subject: [PATCH 142/217] fix the missing value of fv in vege_flux --- physics/module_sf_noahmplsm.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 98364b19c..1c899e4bd 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -3901,6 +3901,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & mpe = 1e-6 liter = 0 + fv = ustarx ! --------------------------------------------------------------------------------------------- ! initialization variables that do not depend on stability iteration ! --------------------------------------------------------------------------------------------- From e8dc7233804baa920a3c044a39d29a56d9b18930 Mon Sep 17 00:00:00 2001 From: "Chunxi.Zhang-NOAA" Date: Tue, 29 Mar 2022 17:35:45 +0000 Subject: [PATCH 143/217] The second updates for the saSAS cumulus scheme to improve the TC intensity forecast and a bug fix related to SL sedimentation of graupel in the Thompson scheme --- physics/mfpbltq.f | 5 +- physics/mfscuq.f | 5 +- physics/module_mp_thompson.F90 | 9 ++- physics/samfdeepcnv.f | 129 +++++++++------------------------ physics/samfshalcnv.f | 98 +++++++++---------------- 5 files changed, 78 insertions(+), 168 deletions(-) diff --git a/physics/mfpbltq.f b/physics/mfpbltq.f index a0788d5b7..c4333290b 100644 --- a/physics/mfpbltq.f +++ b/physics/mfpbltq.f @@ -319,7 +319,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, do k = 1, kmpbl do i = 1, im if (cnvflg(i) .and. k < kpbl(i)) then - xmf(i,k) = sqrt(wu2(i,k)) + xmf(i,k) = a1 * sqrt(wu2(i,k)) endif enddo enddo @@ -356,8 +356,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, do k = 1, kmpbl do i = 1, im if (cnvflg(i) .and. k < kpbl(i)) then - tem = max(a1, sigma(i)) - xmf(i,k) = scaldfunc(i) * tem * xmf(i,k) + xmf(i,k) = scaldfunc(i) * xmf(i,k) dz = zl(i,k+1) - zl(i,k) xmmx = dz / dt2 xmf(i,k) = min(xmf(i,k),xmmx) diff --git a/physics/mfscuq.f b/physics/mfscuq.f index b41ffd13e..3c54b0bda 100644 --- a/physics/mfscuq.f +++ b/physics/mfscuq.f @@ -386,7 +386,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, do i = 1, im if(cnvflg(i) .and. & (k >= mrad(i) .and. k < krad(i))) then - xmfd(i,k) = sqrt(wd2(i,k)) + xmfd(i,k) = ra1(i) * sqrt(wd2(i,k)) endif enddo enddo @@ -424,8 +424,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, do i = 1, im if(cnvflg(i) .and. & (k >= mrad(i) .and. k < krad(i))) then - tem = max(ra1(i), sigma(i)) - xmfd(i,k) = scaldfunc(i) * tem * xmfd(i,k) + xmfd(i,k) = scaldfunc(i) * xmfd(i,k) dz = zl(i,k+1) - zl(i,k) xmmx = dz / dt2 xmfd(i,k) = min(xmfd(i,k),xmmx) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index c23b6d1d8..6d7327e8c 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -4067,7 +4067,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & do k = kte, kts, -1 vtg = 0. if (rg(k).gt. R1) then - vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g + ygra1 = alog10(max(1.E-9, rg(k))) + zans1 = 3.0 + 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 + + vtg = rhof(k)*av_g*cgg(6)*ogg3 * (1./lamg)**bv_g if (temp(k).gt. T_0) then vtgk(k) = MAX(vtg, vtrk(k)) else diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 0420fa1d2..ea92fda7f 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -149,7 +149,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & dh, dhh, dp, & dq, dqsdp, dqsdt, dt, & dt2, dtmax, dtmin, -! & dxcrtas, dxcrtuf, dxcrtc0, & dxcrtas, dxcrtuf, & dv1h, dv2h, dv3h, & dz, dz1, e1, edtmax, @@ -165,7 +164,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & w1, w1l, w1s, w2, & w2l, w2s, w3, w3l, & w3s, w4, w4l, w4s, - & rho, betaw, + & rho, betaw, tauadv, & xdby, xpw, xpwd, ! & xqrch, mbdt, tem, & xqrch, tem, tem1, tem2, @@ -179,8 +178,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! real(kind=kind_phys) aa1(im), acrt(im), acrtfct(im), real(kind=kind_phys) aa1(im), tkemean(im),clamt(im), & ps(im), del(im,km), prsl(im,km), -! & umean(im), tauadv(im), gdx(im), - & gdx(im), + & umean(im), advfac(im), gdx(im), & delhbar(im), delq(im), delq2(im), & delqbar(im), delqev(im), deltbar(im), & deltv(im), dtconv(im), edt(im), @@ -236,7 +234,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & parameter(cinacrmx=-120.,cinacrmn=-80.) parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) parameter(betaw=.03,dxcrtas=8.e3,dxcrtuf=15.e3) -! parameter(dxcrtc0=9.e3) ! ! local variables and arrays @@ -254,7 +251,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & wc(im) ! ! for updraft fraction & scale-aware function -! real(kind=kind_phys) scaldfunc(im), sigmagfm(im), xlamumean(im) real(kind=kind_phys) scaldfunc(im), sigmagfm(im) ! c cloud water @@ -370,6 +366,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & xpwav(i)= 0. xpwev(i)= 0. vshear(i) = 0. + advfac(i) = 0. rainevap(i) = 0. gdx(i) = sqrt(garea(i)) enddo @@ -398,15 +395,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif enddo ! -!> - determine scale-aware rain conversion parameter decreasing with decreasing grid size -! do i=1,im -! if(gdx(i) < dxcrtc0) then -! tem = gdx(i) / dxcrtc0 -! tem1 = tem**2 -! c0(i) = c0(i) * tem1 -! endif -! enddo -! !> - determine rain conversion parameter above the freezing level which exponentially decreases with decreasing temperature from Han et al.'s (2017) \cite han_et_al_2017 equation 8. do k = 1, km do i = 1, im @@ -1028,33 +1016,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & enddo enddo endif -! -! compute mean entrainment rate in subcloud layers below cloud base -! -! do i= 1, im -! if(cnvflg(i)) then -! sumx(i) = 0. -! xlamumean(i) = 0. -! endif -! enddo -! do k = 1, km1 -! do i = 1, im -! if(cnvflg(i)) then -! if(k >= kb(i) .and. k < kbcon(i)) then -! dz = zi(i,k+1) - zi(i,k) -! tem = 0.5 * (xlamue(i,k)+xlamue(i,k+1)) -! xlamumean(i) = xlamumean(i) + tem * dz -! sumx(i) = sumx(i) + dz -! endif -! endif -! enddo -! enddo -! -! do i= 1, im -! if(cnvflg(i)) then -! xlamumean(i) = xlamumean(i) / sumx(i) -! endif -! enddo c c specify detrainment rate for the updrafts c @@ -2796,42 +2757,40 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif ! !> - Calculate advective time scale (tauadv) using a mean cloud layer wind speed. -! do i= 1, im -! if(cnvflg(i)) then -! sumx(i) = 0. -! umean(i) = 0. -! endif -! enddo -! do k = 2, km1 -! do i = 1, im -! if(cnvflg(i)) then -! if(k >= kbcon1(i) .and. k < ktcon1(i)) then -! dz = zi(i,k) - zi(i,k-1) -! tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) -! umean(i) = umean(i) + tem * dz -! sumx(i) = sumx(i) + dz -! endif -! endif -! enddo -! enddo -! do i= 1, im -! if(cnvflg(i)) then -! umean(i) = umean(i) / sumx(i) -! umean(i) = max(umean(i), 1.) -! tauadv(i) = gdx(i) / umean(i) -! endif -! enddo + do i= 1, im + if(cnvflg(i)) then + sumx(i) = 0. + umean(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= kbcon1(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) + umean(i) = umean(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + umean(i) = umean(i) / sumx(i) + umean(i) = max(umean(i), 1.) + tauadv = gdx(i) / umean(i) + advfac(i) = tauadv / dtconv(i) + advfac(i) = min(advfac(i), 1.) + endif + enddo !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. do i= 1, im if(cnvflg(i) .and. .not.asqecflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) -! tfac = tauadv(i) / dtconv(i) -! tfac = min(tfac, 1.) -! xmb(i) = tfac*betaw*rho*wc(i) -! xmb(i) = betaw*rho*wc(i) - xmb(i) = rho*wc(i) + xmb(i) = advfac(i)*betaw*rho*wc(i) endif enddo !> - For the cases where the quasi-equilibrium assumption of Arakawa-Schubert is valid, first calculate the large scale destabilization as in equation 5 of Pan and Wu (1995) \cite pan_and_wu_1995 : @@ -2871,10 +2830,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & !! !! Again when dtconv is larger than tauadv, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. if(asqecflg(i)) then -! tfac = tauadv(i) / dtconv(i) -! tfac = min(tfac, 1.) -! xmb(i) = -tfac * fld(i) / xk(i) - xmb(i) = -fld(i) / xk(i) + xmb(i) = -advfac(i) * fld(i) / xk(i) endif enddo !! @@ -2888,19 +2844,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & !! ! !> - For scale-aware parameterization, the updraft fraction (sigmagfm) is first computed as a function of the lateral entrainment rate at cloud base (see Han et al.'s (2017) \cite han_et_al_2017 equation 4 and 5), following the study by Grell and Freitas (2014) \cite grell_and_freitas_2014. - if(hwrf_samfdeep) then - do i = 1, im - if(cnvflg(i)) then - tem = min(max(xlamx(i), 7.e-5), 3.e-4) -! tem = min(max(xlamumean(i), 1.e-4), 1.e-3) - tem = 0.2 / tem - tem1 = 3.14 * tem * tem - sigmagfm(i) = tem1 / garea(i) - sigmagfm(i) = max(sigmagfm(i), 0.001) - sigmagfm(i) = min(sigmagfm(i), 0.999) - endif - enddo - else do i = 1, im if(cnvflg(i)) then tem = min(max(xlamue(i,kbcon(i)), 7.e-5), 3.e-4) @@ -2911,7 +2854,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & sigmagfm(i) = min(sigmagfm(i), 0.999) endif enddo - endif ! !> - Then, calculate the reduction factor (scaldfunc) of the vertical convective eddy transport of mass flux as a function of updraft fraction from the studies by Arakawa and Wu (2013) \cite arakawa_and_wu_2013 (also see Han et al.'s (2017) \cite han_et_al_2017 equation 1 and 2). The final cloud base mass flux with scale-aware parameterization is obtained from the mass flux when sigmagfm << 1, multiplied by the reduction factor (Han et al.'s (2017) \cite han_et_al_2017 equation 2). do i = 1, im @@ -2922,12 +2864,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & else scaldfunc(i) = 1.0 endif - if(asqecflg(i)) then - xmb(i) = xmb(i) * scaldfunc(i) - else - tem = max(betaw, sigmagfm(i)) - xmb(i) = tem * xmb(i) * scaldfunc(i) - endif + xmb(i) = xmb(i) * scaldfunc(i) xmb(i) = min(xmb(i),xmbmax(i)) endif enddo diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 68b12d169..24e01b040 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -111,7 +111,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & es, etah, h1, shevf, ! & evfact, evfactl, & fact1, fact2, factor, dthk, - & gamma, pprime, betaw, + & gamma, pprime, betaw, tauadv, & qlk, qrch, qs, & rfact, shear, tfac, & val, val1, val2, @@ -128,8 +128,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys) aa1(im), cina(im), & tkemean(im), clamt(im), & ps(im), del(im,km), prsl(im,km), -! & umean(im), tauadv(im), gdx(im), - & gdx(im), + & umean(im), advfac(im), gdx(im), & delhbar(im), delq(im), delq2(im), & delqbar(im), delqev(im), deltbar(im), ! & deltv(im), dtconv(im), edt(im), @@ -180,7 +179,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & parameter(dthk=25.,sfclfac=0.2,rhcrt=0.75) parameter(cinpcrmx=180.,cinpcrmn=120.) ! shevf is an enhancing evaporation factor for shallow convection - parameter(cinacrmx=-120.,shevf=1.0) + parameter(cinacrmx=-120.,shevf=2.0) parameter(dtmax=10800.,dtmin=600.) parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) parameter(betaw=.03,dxcrt=15.e3,dxcrtc0=9.e3) @@ -201,7 +200,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & wc(im) ! ! for updraft fraction & scale-aware function -! real(kind=kind_phys) scaldfunc(im), sigmagfm(im), xlamumean(im) real(kind=kind_phys) scaldfunc(im), sigmagfm(im) ! c cloud water @@ -296,6 +294,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & aa1(i) = 0. cina(i) = 0. ! vshear(i) = 0. + advfac(i) = 0. gdx(i) = sqrt(garea(i)) xmb(i) = 0. scaldfunc(i)=-1.0 ! wang initialized @@ -904,33 +903,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif enddo endif ! hwrf_samfshal -! -! compute mean entrainment rate in subcloud layers below cloud base -! -! do i= 1, im -! if(cnvflg(i)) then -! sumx(i) = 0. -! xlamumean(i) = 0. -! endif -! enddo -! do k = 1, km1 -! do i = 1, im -! if(cnvflg(i)) then -! if(k >= kb(i) .and. k < kbcon(i)) then -! dz = zi(i,k+1) - zi(i,k) -! tem = 0.5 * (xlamue(i,k)+xlamue(i,k+1)) -! xlamumean(i) = xlamumean(i) + tem * dz -! sumx(i) = sumx(i) + dz -! endif -! endif -! enddo -! enddo -! -! do i= 1, im -! if(cnvflg(i)) then -! xlamumean(i) = xlamumean(i) / sumx(i) -! endif -! enddo c c determine updraft mass flux for the subcloud layers c @@ -1821,31 +1793,33 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo ! !> - Calculate advective time scale (tauadv) using a mean cloud layer wind speed. -! do i= 1, im -! if(cnvflg(i)) then -! sumx(i) = 0. -! umean(i) = 0. -! endif -! enddo -! do k = 2, km1 -! do i = 1, im -! if(cnvflg(i)) then -! if(k >= kbcon1(i) .and. k < ktcon1(i)) then -! dz = zi(i,k) - zi(i,k-1) -! tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) -! umean(i) = umean(i) + tem * dz -! sumx(i) = sumx(i) + dz -! endif -! endif -! enddo -! enddo -! do i= 1, im -! if(cnvflg(i)) then -! umean(i) = umean(i) / sumx(i) -! umean(i) = max(umean(i), 1.) -! tauadv(i) = gdx(i) / umean(i) -! endif -! enddo + do i= 1, im + if(cnvflg(i)) then + sumx(i) = 0. + umean(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= kbcon1(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) + umean(i) = umean(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + umean(i) = umean(i) / sumx(i) + umean(i) = max(umean(i), 1.) + tauadv = gdx(i) / umean(i) + advfac(i) = tauadv / dtconv(i) + advfac(i) = min(advfac(i), 1.) + endif + enddo c c compute cloud base mass flux as a function of the mean c updraft velcoity @@ -1856,11 +1830,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(cnvflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) -! tfac = tauadv(i) / dtconv(i) -! tfac = min(tfac, 1.) -! xmb(i) = tfac*betaw*rho*wc(i) -! xmb(i) = betaw*rho*wc(i) - xmb(i) = rho*wc(i) + xmb(i) = advfac(i)*betaw*rho*wc(i) endif enddo ! @@ -1868,7 +1838,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im if(cnvflg(i)) then tem = min(max(xlamue(i,kbcon(i)), 2.e-4), 6.e-4) -! tem = min(max(xlamumean(i), 2.e-4), 2.e-3) tem = 0.2 / tem tem1 = 3.14 * tem * tem sigmagfm(i) = tem1 / garea(i) @@ -1886,8 +1855,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & else scaldfunc(i) = 1.0 endif - tem = max(betaw, sigmagfm(i)) - xmb(i) = tem * xmb(i) * scaldfunc(i) + xmb(i) = xmb(i) * scaldfunc(i) xmb(i) = min(xmb(i),xmbmax(i)) endif enddo From 313d78f7798e6aac27df8d86669163864ada1ebf Mon Sep 17 00:00:00 2001 From: jeff beck Date: Sat, 2 Apr 2022 17:52:58 +0000 Subject: [PATCH 144/217] Fix to original min_rand variable. --- physics/module_mp_thompson.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index c23b6d1d8..cd4acacdc 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1101,7 +1101,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic REAL:: dt, pptrain, pptsnow, pptgraul, pptice REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max - REAL:: rand1, rand2, rand3, min_rand + REAL:: rand1, rand2, rand3, abs_min_rand INTEGER:: i, j, k, m INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr INTEGER:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr @@ -1268,6 +1268,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_ni = 0 kmax_nr = 0 + abs_min_rand = ABS(MINVAL(rand_pert(:,1))) + j_loop: do j = j_start, j_end i_loop: do i = i_start, i_end @@ -1292,7 +1294,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & m = RSHIFT(ABS(rand_perturb_on),1) if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,1)*2. m = RSHIFT(ABS(rand_perturb_on),2) - if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+ABS(min_rand)) + if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+abs_min_rand) m = RSHIFT(ABS(rand_perturb_on),3) endif !+---+-----------------------------------------------------------------+ From 2617af63a5962428e5f11b1b26e362828c0f5dde Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 4 Apr 2022 20:48:03 +0000 Subject: [PATCH 145/217] Cleanup suggestions from PR. --- physics/GFS_cloud_diagnostics.F90 | 4 ++-- physics/GFS_rrtmg_pre.F90 | 2 +- physics/GFS_rrtmgp_cloud_mp.meta | 12 ++++++------ physics/GFS_rrtmgp_cloud_overlap.meta | 2 +- physics/GFS_rrtmgp_pre.meta | 12 ++++++------ physics/rrtmgp_lw_aerosol_optics.meta | 4 ++-- physics/rrtmgp_sw_aerosol_optics.meta | 4 ++-- 7 files changed, 20 insertions(+), 20 deletions(-) diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/GFS_cloud_diagnostics.F90 index 2258cd73f..5dd757a43 100644 --- a/physics/GFS_cloud_diagnostics.F90 +++ b/physics/GFS_cloud_diagnostics.F90 @@ -70,7 +70,7 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m real(kind_phys), dimension(:,:), intent(in) :: & p_lev ! Pressure at model interfaces real(kind_phys), dimension(:,:), intent(in) :: & - deltaZ, & ! Layer thickness (km) + deltaZ, & ! Layer thickness (m) cloud_overlap_param, & ! Cloud-overlap parameter precip_overlap_param ! Precipitation overlap parameter @@ -113,7 +113,7 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m ! layer indices for low, mid, and high clouds. The three cloud domain boundaries are ! defined by ptopc. The cloud overlapping method is defined by control flag 'iovr', which may ! be different for lw and sw radiation programs. - call gethml(p_lay/100., ptop1, cld_frac, cldcnv, deltaZ, de_lgth, cloud_overlap_param,& + call gethml(p_lay*0.01, ptop1, cld_frac, cldcnv, deltaZ, de_lgth, cloud_overlap_param,& nCol, nLev, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & iovr_exprand, cldsa, mtopa, mbota) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index c45cb2b98..46649f7cc 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -674,7 +674,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & IF ( ncnd == 5 ) THEN ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) ! snow + graupel ELSEIF ( ncnd == 6 ) THEN - ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) + tracer1(i,k,nthl) ! snow + gr + ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) + tracer1(i,k,nthl) ! snow + graupel + hail ENDIF endif enddo diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index 88530d84c..f21e93baf 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -266,7 +266,7 @@ kind = kind_phys intent = in [tv_lay] - standard_name = virtual_temperature + standard_name = model_layer_mean_virtual_temperature long_name = layer virtual temperature units = K dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -282,23 +282,23 @@ kind = kind_phys intent = in [qs_lay] - standard_name = saturation_vapor_pressure - long_name = saturation vapor pressure + standard_name = model_layer_mean_saturation_vapor_pressure + long_name = layer saturation vapor pressure units = Pa dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in [q_lay] - standard_name = water_vapor_mixing_ratio - long_name = water vaport mixing ratio + standard_name = model_layer_mean_water_vapor_mixing_ratio + long_name = layer water vaport mixing ratio units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in [relhum] - standard_name = relative_humidity + standard_name = model_layer_mean_relative_humidity long_name = layer relative humidity units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/physics/GFS_rrtmgp_cloud_overlap.meta b/physics/GFS_rrtmgp_cloud_overlap.meta index f7d12bed5..737dbd8be 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.meta +++ b/physics/GFS_rrtmgp_cloud_overlap.meta @@ -75,7 +75,7 @@ kind = kind_phys intent = in [tv_lay] - standard_name = virtual_temperature + standard_name = model_layer_mean_virtual_temperature long_name = layer virtual temperature units = K dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 88face855..ca8710506 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -394,7 +394,7 @@ kind = kind_phys intent = inout [tv_lay] - standard_name = virtual_temperature + standard_name = model_layer_mean_virtual_temperature long_name = layer virtual temperature units = K dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -402,7 +402,7 @@ kind = kind_phys intent = inout [relhum] - standard_name = relative_humidity + standard_name = model_layer_mean_relative_humidity long_name = layer relative humidity units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -410,16 +410,16 @@ kind = kind_phys intent = inout [qs_lay] - standard_name = saturation_vapor_pressure - long_name = saturation vapor pressure + standard_name = model_layer_mean_saturation_vapor_pressure + long_name = layer saturation vapor pressure units = Pa dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout [q_lay] - standard_name = water_vapor_mixing_ratio - long_name = water vaport mixing ratio + standard_name = model_layer_mean_water_vapor_mixing_ratio + long_name = layer water vaport mixing ratio units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real diff --git a/physics/rrtmgp_lw_aerosol_optics.meta b/physics/rrtmgp_lw_aerosol_optics.meta index 165051409..7e226a9fa 100644 --- a/physics/rrtmgp_lw_aerosol_optics.meta +++ b/physics/rrtmgp_lw_aerosol_optics.meta @@ -74,7 +74,7 @@ kind = kind_phys intent = in [tv_lay] - standard_name = virtual_temperature + standard_name = model_layer_mean_virtual_temperature long_name = layer virtual temperature units = K dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -82,7 +82,7 @@ kind = kind_phys intent = in [relhum] - standard_name = relative_humidity + standard_name = model_layer_mean_relative_humidity long_name = layer relative humidity units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/physics/rrtmgp_sw_aerosol_optics.meta b/physics/rrtmgp_sw_aerosol_optics.meta index 2abacd92a..5d500606a 100644 --- a/physics/rrtmgp_sw_aerosol_optics.meta +++ b/physics/rrtmgp_sw_aerosol_optics.meta @@ -81,7 +81,7 @@ kind = kind_phys intent = in [tv_lay] - standard_name = virtual_temperature + standard_name = model_layer_mean_virtual_temperature long_name = layer virtual temperature units = K dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -89,7 +89,7 @@ kind = kind_phys intent = in [relhum] - standard_name = relative_humidity + standard_name = model_layer_mean_relative_humidity long_name = layer relative humidity units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) From 014890566952a9019fc4c02cb1ff0bb85a332229 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 5 Apr 2022 09:40:46 -0600 Subject: [PATCH 146/217] Revert "Cleanup suggestions from PR." This reverts commit 2617af63a5962428e5f11b1b26e362828c0f5dde. --- physics/GFS_cloud_diagnostics.F90 | 4 ++-- physics/GFS_rrtmg_pre.F90 | 2 +- physics/GFS_rrtmgp_cloud_mp.meta | 12 ++++++------ physics/GFS_rrtmgp_cloud_overlap.meta | 2 +- physics/GFS_rrtmgp_pre.meta | 12 ++++++------ physics/rrtmgp_lw_aerosol_optics.meta | 4 ++-- physics/rrtmgp_sw_aerosol_optics.meta | 4 ++-- 7 files changed, 20 insertions(+), 20 deletions(-) diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/GFS_cloud_diagnostics.F90 index 5dd757a43..2258cd73f 100644 --- a/physics/GFS_cloud_diagnostics.F90 +++ b/physics/GFS_cloud_diagnostics.F90 @@ -70,7 +70,7 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m real(kind_phys), dimension(:,:), intent(in) :: & p_lev ! Pressure at model interfaces real(kind_phys), dimension(:,:), intent(in) :: & - deltaZ, & ! Layer thickness (m) + deltaZ, & ! Layer thickness (km) cloud_overlap_param, & ! Cloud-overlap parameter precip_overlap_param ! Precipitation overlap parameter @@ -113,7 +113,7 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m ! layer indices for low, mid, and high clouds. The three cloud domain boundaries are ! defined by ptopc. The cloud overlapping method is defined by control flag 'iovr', which may ! be different for lw and sw radiation programs. - call gethml(p_lay*0.01, ptop1, cld_frac, cldcnv, deltaZ, de_lgth, cloud_overlap_param,& + call gethml(p_lay/100., ptop1, cld_frac, cldcnv, deltaZ, de_lgth, cloud_overlap_param,& nCol, nLev, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & iovr_exprand, cldsa, mtopa, mbota) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 46649f7cc..c45cb2b98 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -674,7 +674,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & IF ( ncnd == 5 ) THEN ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) ! snow + graupel ELSEIF ( ncnd == 6 ) THEN - ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) + tracer1(i,k,nthl) ! snow + graupel + hail + ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) + tracer1(i,k,nthl) ! snow + gr ENDIF endif enddo diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index f21e93baf..88530d84c 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -266,7 +266,7 @@ kind = kind_phys intent = in [tv_lay] - standard_name = model_layer_mean_virtual_temperature + standard_name = virtual_temperature long_name = layer virtual temperature units = K dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -282,23 +282,23 @@ kind = kind_phys intent = in [qs_lay] - standard_name = model_layer_mean_saturation_vapor_pressure - long_name = layer saturation vapor pressure + standard_name = saturation_vapor_pressure + long_name = saturation vapor pressure units = Pa dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in [q_lay] - standard_name = model_layer_mean_water_vapor_mixing_ratio - long_name = layer water vaport mixing ratio + standard_name = water_vapor_mixing_ratio + long_name = water vaport mixing ratio units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in [relhum] - standard_name = model_layer_mean_relative_humidity + standard_name = relative_humidity long_name = layer relative humidity units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/physics/GFS_rrtmgp_cloud_overlap.meta b/physics/GFS_rrtmgp_cloud_overlap.meta index 737dbd8be..f7d12bed5 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.meta +++ b/physics/GFS_rrtmgp_cloud_overlap.meta @@ -75,7 +75,7 @@ kind = kind_phys intent = in [tv_lay] - standard_name = model_layer_mean_virtual_temperature + standard_name = virtual_temperature long_name = layer virtual temperature units = K dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index ca8710506..88face855 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -394,7 +394,7 @@ kind = kind_phys intent = inout [tv_lay] - standard_name = model_layer_mean_virtual_temperature + standard_name = virtual_temperature long_name = layer virtual temperature units = K dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -402,7 +402,7 @@ kind = kind_phys intent = inout [relhum] - standard_name = model_layer_mean_relative_humidity + standard_name = relative_humidity long_name = layer relative humidity units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -410,16 +410,16 @@ kind = kind_phys intent = inout [qs_lay] - standard_name = model_layer_mean_saturation_vapor_pressure - long_name = layer saturation vapor pressure + standard_name = saturation_vapor_pressure + long_name = saturation vapor pressure units = Pa dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout [q_lay] - standard_name = model_layer_mean_water_vapor_mixing_ratio - long_name = layer water vaport mixing ratio + standard_name = water_vapor_mixing_ratio + long_name = water vaport mixing ratio units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real diff --git a/physics/rrtmgp_lw_aerosol_optics.meta b/physics/rrtmgp_lw_aerosol_optics.meta index 7e226a9fa..165051409 100644 --- a/physics/rrtmgp_lw_aerosol_optics.meta +++ b/physics/rrtmgp_lw_aerosol_optics.meta @@ -74,7 +74,7 @@ kind = kind_phys intent = in [tv_lay] - standard_name = model_layer_mean_virtual_temperature + standard_name = virtual_temperature long_name = layer virtual temperature units = K dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -82,7 +82,7 @@ kind = kind_phys intent = in [relhum] - standard_name = model_layer_mean_relative_humidity + standard_name = relative_humidity long_name = layer relative humidity units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/physics/rrtmgp_sw_aerosol_optics.meta b/physics/rrtmgp_sw_aerosol_optics.meta index 5d500606a..2abacd92a 100644 --- a/physics/rrtmgp_sw_aerosol_optics.meta +++ b/physics/rrtmgp_sw_aerosol_optics.meta @@ -81,7 +81,7 @@ kind = kind_phys intent = in [tv_lay] - standard_name = model_layer_mean_virtual_temperature + standard_name = virtual_temperature long_name = layer virtual temperature units = K dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -89,7 +89,7 @@ kind = kind_phys intent = in [relhum] - standard_name = model_layer_mean_relative_humidity + standard_name = relative_humidity long_name = layer relative humidity units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) From 2cf6a38106ee56220b579e9abc344bea938e6e36 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 5 Apr 2022 09:42:53 -0600 Subject: [PATCH 147/217] Cleanup --- physics/GFS_cloud_diagnostics.F90 | 4 ++-- physics/GFS_rrtmg_pre.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/GFS_cloud_diagnostics.F90 index 2258cd73f..5dd757a43 100644 --- a/physics/GFS_cloud_diagnostics.F90 +++ b/physics/GFS_cloud_diagnostics.F90 @@ -70,7 +70,7 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m real(kind_phys), dimension(:,:), intent(in) :: & p_lev ! Pressure at model interfaces real(kind_phys), dimension(:,:), intent(in) :: & - deltaZ, & ! Layer thickness (km) + deltaZ, & ! Layer thickness (m) cloud_overlap_param, & ! Cloud-overlap parameter precip_overlap_param ! Precipitation overlap parameter @@ -113,7 +113,7 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m ! layer indices for low, mid, and high clouds. The three cloud domain boundaries are ! defined by ptopc. The cloud overlapping method is defined by control flag 'iovr', which may ! be different for lw and sw radiation programs. - call gethml(p_lay/100., ptop1, cld_frac, cldcnv, deltaZ, de_lgth, cloud_overlap_param,& + call gethml(p_lay*0.01, ptop1, cld_frac, cldcnv, deltaZ, de_lgth, cloud_overlap_param,& nCol, nLev, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & iovr_exprand, cldsa, mtopa, mbota) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index c45cb2b98..46649f7cc 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -674,7 +674,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & IF ( ncnd == 5 ) THEN ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) ! snow + graupel ELSEIF ( ncnd == 6 ) THEN - ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) + tracer1(i,k,nthl) ! snow + gr + ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) + tracer1(i,k,nthl) ! snow + graupel + hail ENDIF endif enddo From 6342e52f18260f9a5f50bdad39e84c7aa964d7a5 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Tue, 5 Apr 2022 23:22:26 +0000 Subject: [PATCH 148/217] Pass SPP namelist entries into Thompson MP --- physics/module_mp_thompson.F90 | 23 ++++++++++++++++++----- physics/mp_thompson.F90 | 12 ++++++++++-- physics/mp_thompson.meta | 20 ++++++++++++++++++++ 3 files changed, 48 insertions(+), 7 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index cd4acacdc..a269d8c66 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -984,7 +984,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & has_reqc, has_reqi, has_reqs, & rand_perturb_on, & kme_stoch, & - rand_pert, & + rand_pert, spp_prt_list,spp_var_list & + spp_stddev_cutoff,n_var_spp & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims @@ -1027,7 +1028,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & re_cloud, re_ice, re_snow INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch REAL, DIMENSION(:,:), INTENT(IN) :: & - rand_pert + rand_pert,spp_prt_list,spp_stddev_cutoff,n_var_spp, & + spp_var_list INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs #if ( WRF_CHEM == 1 ) @@ -1101,7 +1103,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic REAL:: dt, pptrain, pptsnow, pptgraul, pptice REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max - REAL:: rand1, rand2, rand3, abs_min_rand + REAL:: rand1, rand2, rand3, spp_mp_mag_times_cutoff INTEGER:: i, j, k, m INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr INTEGER:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr @@ -1268,7 +1270,18 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_ni = 0 kmax_nr = 0 - abs_min_rand = ABS(MINVAL(rand_pert(:,1))) + !Get the Thompson MP SPP magnitude and standard deviation cutoff + + if (rand_perturb_on .ne. 0) then + do k =1,n_var_spp + select case (spp_var_list(k)) + case('mp') + spp_mp_mag_times_cutoff = spp_prt_list(k)*spp_stddev_cutoff(k) + end select + enddo + endif + + print*, ' spp_mp_mag_times_cutoff is = ', spp_mp_mag_times_cutoff j_loop: do j = j_start, j_end i_loop: do i = i_start, i_end @@ -1294,7 +1307,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & m = RSHIFT(ABS(rand_perturb_on),1) if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,1)*2. m = RSHIFT(ABS(rand_perturb_on),2) - if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+abs_min_rand) + if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+spp_mp_mag_times_cutoff) m = RSHIFT(ABS(rand_perturb_on),3) endif !+---+-----------------------------------------------------------------+ diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 7c76ea933..cb8bfafa0 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -376,7 +376,11 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! SPP integer, intent(in) :: spp_mp + integer, intent(in) :: n_var_spp real(kind_phys), intent(in) :: spp_wts_mp(:,:) + real(kind_phys), intent(in) :: spp_prt_list(:) + character(len=3), intent(in) :: spp_var_list(:) + real(kind_phys), intent(in) :: spp_stddev_cutoff(:) ! Local variables @@ -644,7 +648,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & 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, & + rand_pert=spp_wts_mp,spp_var_list=spp_var_list_out, & + spp_prt_list=spp_prt_list_out,n_var_spp=n_var_spp, & + spp_stddev_cutoff=spp_stddev_cutoff_out, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & @@ -681,7 +687,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & 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, & + rand_pert=spp_wts_mp,spp_prt_list=spp_prt_list_out, & + spp_stddev_cutoff=spp_stddev_cutoff_out,n_var_spp=n_var_spp, & + spp_var_list=spp_var_list_out, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index a3bc20615..86fbd045a 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -653,6 +653,26 @@ dimensions = () type = integer intent = in +[n_var_spp] + standard_name = number_of_perturbed_spp_schemes + long_name = number of perturbed spp schemes + units = count + dimensions = () + type = integer +[spp_prt_list] + standard_name = magnitude_of_spp_perturbations + long_name = magnitude of spp perturbations + units = 1 + dimensions = (number_of_spp_schemes_perturbed) + type = real + kind = kind_phys +[spp_stddev_cutoff] + standard_name = magnitude_of_spp_standard_deviation_cutoff + long_name = magnitude of spp standard deviation cutoff + units = 1 + dimensions = (number_of_spp_schemes_perturbed) + type = real + kind = kind_phys [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 16993b9cde77c1a4c80dee010c4436737ec20c4e Mon Sep 17 00:00:00 2001 From: jeff beck Date: Wed, 6 Apr 2022 00:12:59 +0000 Subject: [PATCH 149/217] Add intent to SPP variables in meta file. --- physics/mp_thompson.meta | 3 +++ 1 file changed, 3 insertions(+) diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 86fbd045a..a08364107 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -659,6 +659,7 @@ units = count dimensions = () type = integer + intent = in [spp_prt_list] standard_name = magnitude_of_spp_perturbations long_name = magnitude of spp perturbations @@ -666,6 +667,7 @@ dimensions = (number_of_spp_schemes_perturbed) type = real kind = kind_phys + intent = in [spp_stddev_cutoff] standard_name = magnitude_of_spp_standard_deviation_cutoff long_name = magnitude of spp standard deviation cutoff @@ -673,6 +675,7 @@ dimensions = (number_of_spp_schemes_perturbed) type = real kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 084551f20fae11029e30d4ab48d603c13396463b Mon Sep 17 00:00:00 2001 From: jeff beck Date: Wed, 6 Apr 2022 00:43:40 +0000 Subject: [PATCH 150/217] Fix dimensions in the Thompson meta file --- physics/mp_thompson.meta | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index a08364107..e628b824e 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -664,7 +664,7 @@ standard_name = magnitude_of_spp_perturbations long_name = magnitude of spp perturbations units = 1 - dimensions = (number_of_spp_schemes_perturbed) + dimensions = () type = real kind = kind_phys intent = in @@ -672,7 +672,7 @@ standard_name = magnitude_of_spp_standard_deviation_cutoff long_name = magnitude of spp standard deviation cutoff units = 1 - dimensions = (number_of_spp_schemes_perturbed) + dimensions = () type = real kind = kind_phys intent = in From 4407989d07cdcc33eaacd2d6f0d3ce27db429682 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 6 Apr 2022 19:43:49 +0000 Subject: [PATCH 151/217] Added bounding to temperature at layer-interface used by RRTMGP. --- physics/GFS_rrtmgp_pre.F90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 53504c8dd..1265cf378 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -180,7 +180,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw gas_concentrations ! RRTMGP DDT: gas volumne mixing ratios ! Local variables - integer :: i, j, iCol, iBand, iLay + integer :: i, j, iCol, iBand, iLay, iLev, iSFC_ilev real(kind_phys),dimension(nCol,nLev) :: vmr_o3, vmr_h2o real(kind_phys) :: es, tem1, tem2, pfac real(kind_phys), dimension(nLev+1) :: hgtb @@ -202,9 +202,11 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw if (top_at_1) then iSFC = nLev iTOA = 1 + iSFC_ilev = iSFC + 1 else iSFC = 1 iTOA = nLev + iSFC_ilev = 1 endif ! ####################################################################################### @@ -244,6 +246,12 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! Temperature at layer-interfaces call cmp_tlev(nCol,nLev,minGPpres,p_lay,t_lay,p_lev,tsfc,t_lev) + do iCol=1,nCol + do iLev=1,nLev+1 + if (t_lev(iCol,iLev) .le. minGPtemp) t_lev(iCol,iLev) = minGPtemp + epsilon(minGPtemp) + if (t_lev(iCol,iLev) .ge. maxGPtemp) t_lev(iCol,iLev) = maxGPtemp - epsilon(maxGPtemp) + enddo + enddo ! Save surface temperature at radiation time-step, used for LW flux adjustment betwen ! radiation calls. @@ -361,7 +369,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! ####################################################################################### ! Setup surface ground temperature and ground/air skin temperature if required. ! ####################################################################################### - tsfg(1:NCOL) = tsfc(1:NCOL) + tsfg(1:NCOL) = t_lev(1:NCOL,iSFC_ilev) tsfa(1:NCOL) = t_lay(1:NCOL,iSFC) ! ####################################################################################### From d0a2dd8a65efbe06a99278595c2b6d53c63ad421 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 6 Apr 2022 20:17:06 +0000 Subject: [PATCH 152/217] Reorder loop --- physics/GFS_rrtmgp_pre.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 1265cf378..faf8d4986 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -227,8 +227,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw t_lay(1:NCOL,:) = tgrs(1:NCOL,:) ! Bound temperature/pressure at layer centers. - do iCol=1,NCOL - do iLay=1,nLev + do iLay=1,nLev + do iCol=1,NCOL if (t_lay(iCol,iLay) .le. minGPtemp) then t_lay(iCol,iLay) = minGPtemp + epsilon(minGPtemp) endif @@ -246,8 +246,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! Temperature at layer-interfaces call cmp_tlev(nCol,nLev,minGPpres,p_lay,t_lay,p_lev,tsfc,t_lev) - do iCol=1,nCol - do iLev=1,nLev+1 + do iLev=1,nLev+1 + do iCol=1,nCol if (t_lev(iCol,iLev) .le. minGPtemp) t_lev(iCol,iLev) = minGPtemp + epsilon(minGPtemp) if (t_lev(iCol,iLev) .ge. maxGPtemp) t_lev(iCol,iLev) = maxGPtemp - epsilon(maxGPtemp) enddo @@ -260,8 +260,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! Compute a bunch of thermodynamic fields needed by the cloud microphysics schemes. ! Relative humidity, saturation mixing-ratio, vapor mixing-ratio, virtual temperature, ! layer thickness,... - do iCol=1,NCOL - do iLay=1,nLev + do iLay=1,nLev + do iCol=1,NCOL es = min( p_lay(iCol,iLay), fpvs( t_lay(iCol,iLay) ) ) ! fpvs and prsl in pa qs_lay(iCol,iLay) = max( con_epsqs, con_eps * es / (p_lay(iCol,iLay) + con_epsm1*es) ) relhum(iCol,iLay) = max( 0._kind_phys, min( 1._kind_phys, max(con_epsqs, q_lay(iCol,iLay))/qs_lay(iCol,iLay) ) ) From a2fefa76e4ed84716af113476aa933a9826e619b Mon Sep 17 00:00:00 2001 From: jeff beck Date: Wed, 6 Apr 2022 21:30:54 +0000 Subject: [PATCH 153/217] Fixes to application of rand_pert_max in Thompson MP. --- physics/module_mp_thompson.F90 | 43 +++++++++++++++++----------------- physics/mp_thompson.F90 | 16 +++++++------ physics/mp_thompson.meta | 13 +++++++--- 3 files changed, 40 insertions(+), 32 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index a269d8c66..9e811b7d8 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -984,8 +984,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & has_reqc, has_reqi, has_reqs, & rand_perturb_on, & kme_stoch, & - rand_pert, spp_prt_list,spp_var_list & - spp_stddev_cutoff,n_var_spp & + rand_pert, spp_prt_list, spp_var_list, & + spp_stddev_cutoff, n_var_spp, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims @@ -1026,11 +1026,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d, nifa2d REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & re_cloud, re_ice, re_snow - INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch - REAL, DIMENSION(:,:), INTENT(IN) :: & - rand_pert,spp_prt_list,spp_stddev_cutoff,n_var_spp, & - spp_var_list - + INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch, n_var_spp + REAL, DIMENSION(:,:), INTENT(IN) :: rand_pert + REAL, DIMENSION(:), INTENT(IN) :: spp_prt_list, spp_stddev_cutoff + CHARACTER(len=3), DIMENSION(:), INTENT(IN) :: spp_var_list INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs #if ( WRF_CHEM == 1 ) REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & @@ -1103,7 +1102,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic REAL:: dt, pptrain, pptsnow, pptgraul, pptice REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max - REAL:: rand1, rand2, rand3, spp_mp_mag_times_cutoff + REAL:: rand1, rand2, rand3, rand_pert_max INTEGER:: i, j, k, m INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr INTEGER:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr @@ -1235,10 +1234,23 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & pcp_sn(:,:) = 0.0 pcp_gr(:,:) = 0.0 pcp_ic(:,:) = 0.0 + rand_pert_max = 0.0 ndt = max(nint(dt_in/dt_inner),1) dt = dt_in/ndt if(dt_in .le. dt_inner) dt= dt_in + !Get the Thompson MP SPP magnitude and standard deviation cutoff, + !then compute rand_pert_max + + if (rand_perturb_on .ne. 0) then + do k =1,n_var_spp + select case (spp_var_list(k)) + case('mp') + rand_pert_max = spp_prt_list(k)*spp_stddev_cutoff(k) + end select + enddo + endif + do it = 1, ndt qc_max = 0. @@ -1270,19 +1282,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_ni = 0 kmax_nr = 0 - !Get the Thompson MP SPP magnitude and standard deviation cutoff - - if (rand_perturb_on .ne. 0) then - do k =1,n_var_spp - select case (spp_var_list(k)) - case('mp') - spp_mp_mag_times_cutoff = spp_prt_list(k)*spp_stddev_cutoff(k) - end select - enddo - endif - - print*, ' spp_mp_mag_times_cutoff is = ', spp_mp_mag_times_cutoff - j_loop: do j = j_start, j_end i_loop: do i = i_start, i_end @@ -1307,7 +1306,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & m = RSHIFT(ABS(rand_perturb_on),1) if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,1)*2. m = RSHIFT(ABS(rand_perturb_on),2) - if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+spp_mp_mag_times_cutoff) + if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+rand_pert_max) m = RSHIFT(ABS(rand_perturb_on),3) endif !+---+-----------------------------------------------------------------+ diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index cb8bfafa0..d8dbc9300 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -308,7 +308,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & refl_10cm, reset_dBZ, do_radar_ref, & mpicomm, mpirank, mpiroot, blkno, & ext_diag, diag3d, reset_diag3d, & - spp_wts_mp, spp_mp, & + spp_wts_mp, spp_mp, n_var_spp, & + spp_prt_list, spp_var_list, & + spp_stddev_cutoff, & errmsg, errflg) implicit none @@ -648,9 +650,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & 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_out, & - spp_prt_list=spp_prt_list_out,n_var_spp=n_var_spp, & - spp_stddev_cutoff=spp_stddev_cutoff_out, & + rand_pert=spp_wts_mp, spp_var_list=spp_var_list, & + spp_prt_list=spp_prt_list, n_var_spp=n_var_spp, & + spp_stddev_cutoff=spp_stddev_cutoff, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & @@ -687,9 +689,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & 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_prt_list=spp_prt_list_out, & - spp_stddev_cutoff=spp_stddev_cutoff_out,n_var_spp=n_var_spp, & - spp_var_list=spp_var_list_out, & + rand_pert=spp_wts_mp, spp_prt_list=spp_prt_list, & + spp_stddev_cutoff=spp_stddev_cutoff, n_var_spp=n_var_spp, & + spp_var_list=spp_var_list, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index e628b824e..f9bc6a9f4 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -644,7 +644,6 @@ units = 1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real - kind = kind_phys intent = in [spp_mp] standard_name = control_for_microphysics_spp_perturbations @@ -664,7 +663,7 @@ standard_name = magnitude_of_spp_perturbations long_name = magnitude of spp perturbations units = 1 - dimensions = () + dimensions = (number_of_spp_schemes_perturbed) type = real kind = kind_phys intent = in @@ -672,10 +671,18 @@ standard_name = magnitude_of_spp_standard_deviation_cutoff long_name = magnitude of spp standard deviation cutoff units = 1 - dimensions = () + dimensions = (number_of_spp_schemes_perturbed) type = real kind = kind_phys intent = in +[spp_var_list] + standard_name = perturbed_spp_schemes + long_name = perturbed spp schemes + units = none + dimensions = (number_of_spp_schemes_perturbed) + type = character + kind = len=3 + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 77aa061dfeb16a2357cf216911525d9c3fa00f88 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 6 Apr 2022 22:01:59 +0000 Subject: [PATCH 154/217] Combined gp sw and lw aerosol routines. Modest speedup (~4%) --- ...l_optics.F90 => rrtmgp_aerosol_optics.F90} | 54 ++++--- ...optics.meta => rrtmgp_aerosol_optics.meta} | 18 ++- physics/rrtmgp_lw_aerosol_optics.F90 | 104 ------------ physics/rrtmgp_lw_aerosol_optics.meta | 153 ------------------ 4 files changed, 45 insertions(+), 284 deletions(-) rename physics/{rrtmgp_sw_aerosol_optics.F90 => rrtmgp_aerosol_optics.F90} (74%) rename physics/{rrtmgp_sw_aerosol_optics.meta => rrtmgp_aerosol_optics.meta} (90%) delete mode 100644 physics/rrtmgp_lw_aerosol_optics.F90 delete mode 100644 physics/rrtmgp_lw_aerosol_optics.meta diff --git a/physics/rrtmgp_sw_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 similarity index 74% rename from physics/rrtmgp_sw_aerosol_optics.F90 rename to physics/rrtmgp_aerosol_optics.F90 index afd039249..eb7797125 100644 --- a/physics/rrtmgp_sw_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -1,7 +1,7 @@ -module rrtmgp_sw_aerosol_optics +module rrtmgp_aerosol_optics use machine, only: kind_phys use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_2str + use mo_optical_props, only: ty_optical_props_2str, ty_optical_props_1scl use radiation_tools, only: check_error_msg use rrtmgp_sw_gas_optics, only: sw_gas_props use rrtmgp_lw_gas_optics, only: lw_gas_props @@ -14,29 +14,24 @@ module rrtmgp_sw_aerosol_optics implicit none - public rrtmgp_sw_aerosol_optics_init, rrtmgp_sw_aerosol_optics_run, rrtmgp_sw_aerosol_optics_finalize + public rrtmgp_aerosol_optics_run contains ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_aerosol_optics_init() + ! SUBROUTINE rrtmgp_aerosol_optics_run() ! ######################################################################################### - subroutine rrtmgp_sw_aerosol_optics_init() - end subroutine rrtmgp_sw_aerosol_optics_init - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_aerosol_optics_run() - ! ######################################################################################### -!! \section arg_table_rrtmgp_sw_aerosol_optics_run -!! \htmlinclude rrtmgp_sw_aerosol_optics_run.html +!! \section arg_table_rrtmgp_aerosol_optics_run +!! \htmlinclude rrtmgp_aerosol_optics_run.html !! - subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer, nDay, & - idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - aerodp, sw_optical_props_aerosol, errmsg, errflg ) + subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTracerAer, & + nDay, idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & + aerodp, sw_optical_props_aerosol, lw_optical_props_aerosol, errmsg, errflg ) ! Inputs logical, intent(in) :: & - doSWrad ! Logical flag for shortwave radiation call + doSWrad, & ! Logical flag for shortwave radiation call + doLWrad ! Logical flag for longwave radiation call integer, intent(in) :: & nCol, & ! Number of horizontal grid points nDay, & ! Number of daylit points @@ -66,6 +61,8 @@ subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer aerodp ! Vertical integrated optical depth for various aerosol species type(ty_optical_props_2str),intent(out) :: & sw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) + type(ty_optical_props_1scl),intent(inout) :: & + lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) integer, intent(out) :: & errflg ! CCPP error flag character(len=*), intent(out) :: & @@ -76,6 +73,7 @@ subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer aerosolslw ! real(kind_phys), dimension(nCol, nLev, sw_gas_props%get_nband(), NF_AESW) :: & aerosolssw, aerosolssw2 + integer :: iBand ! Initialize CCPP error handling variables errmsg = '' @@ -84,9 +82,10 @@ subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer if (.not. doSWrad) return ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile - call setaer(p_lev/100., p_lay/100., p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & + call setaer(p_lev*0.01, p_lay*0.01, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & nLev+1, .true., .true., aerosolssw2, aerosolslw, aerodp) + ! Shortwave if (nDay .gt. 0) then ! Store aerosol optical properties ! SW. @@ -100,7 +99,7 @@ subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),3) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,3) ! Allocate RRTMGP DDT: Aerosol optics [nCol,nlev,nBands] - call check_error_msg('rrtmgp_sw_aerosol_optics_run',sw_optical_props_aerosol%alloc_2str( & + call check_error_msg('rrtmgp_aerosol_optics_run',sw_optical_props_aerosol%alloc_2str( & nDay, nlev, sw_gas_props%get_band_lims_wavenumber())) ! Copy aerosol optical information to RRTMGP DDT @@ -109,11 +108,16 @@ subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer sw_optical_props_aerosol%g = aerosolssw(idxday(1:nday),:,:,3) endif - end subroutine rrtmgp_sw_aerosol_optics_run + ! Longwave + if (.not. doLWrad) return + lw_optical_props_aerosol%tau = aerosolslw(:,:,:,1) * (1. - aerosolslw(:,:,:,2)) + + lw_optical_props_aerosol%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_aerosol%band2gpt(1:2,iBand) = iBand + lw_optical_props_aerosol%gpt2band(iBand) = iBand + end do + + end subroutine rrtmgp_aerosol_optics_run - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_aerosol_optics_finalize() - ! ######################################################################################### - subroutine rrtmgp_sw_aerosol_optics_finalize() - end subroutine rrtmgp_sw_aerosol_optics_finalize -end module rrtmgp_sw_aerosol_optics +end module rrtmgp_aerosol_optics diff --git a/physics/rrtmgp_sw_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta similarity index 90% rename from physics/rrtmgp_sw_aerosol_optics.meta rename to physics/rrtmgp_aerosol_optics.meta index 2abacd92a..cd7c77d4d 100644 --- a/physics/rrtmgp_sw_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = rrtmgp_sw_aerosol_optics + name = rrtmgp_aerosol_optics type = scheme dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radiation_tools.F90 ######################################################################## [ccpp-arg-table] - name = rrtmgp_sw_aerosol_optics_run + name = rrtmgp_aerosol_optics_run type = scheme [doSWrad] standard_name = flag_for_calling_shortwave_radiation @@ -14,6 +14,13 @@ dimensions = () type = logical intent = in +[doLWrad] + standard_name = flag_for_calling_longwave_radiation + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -151,6 +158,13 @@ dimensions = () type = ty_optical_props_2str intent = out +[lw_optical_props_aerosol] + standard_name = longwave_optical_properties_for_aerosols + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_1scl + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/rrtmgp_lw_aerosol_optics.F90 b/physics/rrtmgp_lw_aerosol_optics.F90 deleted file mode 100644 index de42db1cd..000000000 --- a/physics/rrtmgp_lw_aerosol_optics.F90 +++ /dev/null @@ -1,104 +0,0 @@ -module rrtmgp_lw_aerosol_optics - use machine, only: kind_phys - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_1scl - use radiation_tools, only: check_error_msg - use rrtmgp_sw_gas_optics, only: sw_gas_props - use rrtmgp_lw_gas_optics, only: lw_gas_props - use module_radiation_aerosols, only: & - NF_AESW, & ! Number of optical-fields in SW output (3=tau+g+omega) - NF_AELW, & ! Number of optical-fields in LW output (3=tau+g+omega) - setaer, & ! Routine to compute aerosol radiative properties (tau,g,omega) - NSPC1 ! Number of species for vertically integrated aerosol optical-depth - use netcdf - - implicit none - - public rrtmgp_lw_aerosol_optics_init, rrtmgp_lw_aerosol_optics_run, rrtmgp_lw_aerosol_optics_finalize - -contains - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_aerosol_optics_init() - ! ######################################################################################### - subroutine rrtmgp_lw_aerosol_optics_init() - end subroutine rrtmgp_lw_aerosol_optics_init - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_aerosol_optics_run() - ! ######################################################################################### -!! \section arg_table_rrtmgp_lw_aerosol_optics_run -!! \htmlinclude rrtmgp_lw_aerosol_optics.html -!! - subroutine rrtmgp_lw_aerosol_optics_run(doLWrad, nCol, nLev, nspc, nTracer, nTracerAer, & - p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - lw_optical_props_aerosol, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doLWrad ! Logical flag for longwave radiation call - integer, intent(in) :: & - nCol, & ! Number of horizontal grid points - nLev, & ! Number of vertical layers - nspc, & ! Number of aerosol optical-depths - nTracer, & ! Number of tracers - nTracerAer ! Number of aerosol tracers - real(kind_phys), dimension(:), intent(in) :: & - lon, & ! Longitude - lat, & ! Latitude - lsmask ! Land/sea/sea-ice mask - real(kind_phys), dimension(:,:),intent(in) :: & - p_lay, & ! Pressure @ layer-centers (Pa) - tv_lay, & ! Virtual-temperature @ layer-centers (K) - relhum, & ! Relative-humidity @ layer-centers - p_lk ! Exner function @ layer-centers (1) - real(kind_phys), dimension(:,:, :),intent(in) :: & - tracer ! trace gas concentrations - real(kind_phys), dimension(:,:, :),intent(in) :: & - aerfld ! aerosol input concentrations - real(kind_phys), dimension(:,:),intent(in) :: & - p_lev ! Pressure @ layer-interfaces (Pa) - - ! Outputs - type(ty_optical_props_1scl),intent(inout) :: & - lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) - integer, intent(out) :: & - errflg ! CCPP error flag - character(len=*), intent(out) :: & - errmsg ! CCPP error message - - ! Local variables - real(kind_phys), dimension(nCol, nLev, lw_gas_props%get_nband(), NF_AELW) :: & - aerosolslw ! - real(kind_phys), dimension(nCol, nLev, sw_gas_props%get_nband(), NF_AESW) :: & - aerosolssw - real(kind_phys), dimension(nCol,nspc) :: aerodp - integer :: iBand - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doLWrad) return - - ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile - call setaer(p_lev/100., p_lay/100., p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, ncol, nLev, & - nLev+1, .true., .true., aerosolssw, aerosolslw, aerodp) - - ! Copy aerosol optical information to RRTMGP DDT - lw_optical_props_aerosol%tau = aerosolslw(:,:,:,1) * (1. - aerosolslw(:,:,:,2)) - - lw_optical_props_aerosol%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_aerosol%band2gpt(1:2,iBand) = iBand - lw_optical_props_aerosol%gpt2band(iBand) = iBand - end do - - end subroutine rrtmgp_lw_aerosol_optics_run - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_aerosol_optics_finalize() - ! ######################################################################################### - subroutine rrtmgp_lw_aerosol_optics_finalize() - end subroutine rrtmgp_lw_aerosol_optics_finalize -end module rrtmgp_lw_aerosol_optics diff --git a/physics/rrtmgp_lw_aerosol_optics.meta b/physics/rrtmgp_lw_aerosol_optics.meta deleted file mode 100644 index 165051409..000000000 --- a/physics/rrtmgp_lw_aerosol_optics.meta +++ /dev/null @@ -1,153 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_aerosol_optics - type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radiation_tools.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_aerosol_optics_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nspc] - standard_name = number_of_species_for_aerosol_optical_depth - long_name = number of species for output aerosol optical depth plus total - units = count - dimensions = () - type = integer - intent = in -[nTracer] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[nTracerAer] - standard_name = number_of_aerosol_tracers_MG - long_name = number of aerosol tracers for Morrison Gettelman MP - units = count - dimensions = () - type = integer - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure at vertical interface for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure at vertical layer for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lk] - standard_name = dimensionless_exner_function - long_name = dimensionless Exner function at model layer centers - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tv_lay] - standard_name = virtual_temperature - long_name = layer virtual temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[relhum] - standard_name = relative_humidity - long_name = layer relative humidity - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[lsmask] - standard_name = area_type - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[aerfld] - standard_name = mass_number_concentration_of_aerosol_from_gocart_climatology - long_name = GOCART aerosol climatology number concentration - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_tracers_MG) - type = real - kind = kind_phys - intent = in -[lon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lw_optical_props_aerosol] - standard_name = longwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl - 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 From 044c900ae87cb017a83527fe0d77a7a86c24be76 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Thu, 7 Apr 2022 21:28:21 +0000 Subject: [PATCH 155/217] Fix metadata descriptions. --- physics/mp_thompson.meta | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index f9bc6a9f4..cedd63e68 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -663,7 +663,7 @@ standard_name = magnitude_of_spp_perturbations long_name = magnitude of spp perturbations units = 1 - dimensions = (number_of_spp_schemes_perturbed) + dimensions = (number_of_perturbed_spp_schemes) type = real kind = kind_phys intent = in @@ -671,7 +671,7 @@ standard_name = magnitude_of_spp_standard_deviation_cutoff long_name = magnitude of spp standard deviation cutoff units = 1 - dimensions = (number_of_spp_schemes_perturbed) + dimensions = (number_of_perturbed_spp_schemes) type = real kind = kind_phys intent = in From fdc9b2e61609041cc3c0f778a9007325161127a4 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Thu, 7 Apr 2022 21:29:52 +0000 Subject: [PATCH 156/217] Fix last metadata entry. --- physics/mp_thompson.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index cedd63e68..3d10f40d6 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -679,7 +679,7 @@ standard_name = perturbed_spp_schemes long_name = perturbed spp schemes units = none - dimensions = (number_of_spp_schemes_perturbed) + dimensions = (number_of_perturbed_spp_schemes) type = character kind = len=3 intent = in From 58917678aceb22b8793bf1fd5da811e40c282c4e Mon Sep 17 00:00:00 2001 From: haiqinli <38666296+haiqinli@users.noreply.github.com> Date: Fri, 8 Apr 2022 12:24:22 -0600 Subject: [PATCH 157/217] Create readme --- smoke/readme | 1 + 1 file changed, 1 insertion(+) create mode 100644 smoke/readme diff --git a/smoke/readme b/smoke/readme new file mode 100644 index 000000000..e8027d7fa --- /dev/null +++ b/smoke/readme @@ -0,0 +1 @@ +the smoke directory From 9137366b24fac03809ece6c1c7aeee58a673dd0b Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Fri, 8 Apr 2022 18:28:52 +0000 Subject: [PATCH 158/217] "add smoke subroutines" --- smoke/dep_dry_gocart_mod.F90 | 298 ++++ smoke/dep_dry_mod.F90 | 300 ++++ smoke/dep_simple_mod.F90 | 763 +++++++++ smoke/dep_vertmx_mod.F90 | 209 +++ smoke/dep_wet_ls_mod.F90 | 565 +++++++ smoke/dust_data_mod.F90 | 108 ++ smoke/dust_fengsha_mod.F90 | 598 +++++++ smoke/module_add_emiss_burn.F90 | 223 +++ smoke/module_plumerise1.F90 | 211 +++ smoke/module_smoke_plumerise.F90 | 2345 +++++++++++++++++++++++++++ smoke/module_zero_plumegen_coms.F90 | 192 +++ smoke/plume_data_mod.F90 | 49 + smoke/readme | 1 - smoke/rrfs_smoke_config.F90 | 125 ++ smoke/rrfs_smoke_data.F90 | 644 ++++++++ smoke/rrfs_smoke_lsdep_wrapper.F90 | 338 ++++ smoke/rrfs_smoke_lsdep_wrapper.meta | 210 +++ smoke/rrfs_smoke_postpbl.F90 | 73 + smoke/rrfs_smoke_postpbl.meta | 85 + smoke/rrfs_smoke_wrapper.F90 | 762 +++++++++ smoke/rrfs_smoke_wrapper.meta | 632 ++++++++ smoke/seas_data_mod.F90 | 18 + smoke/seas_mod.F90 | 429 +++++ smoke/seas_ngac_mod.F90 | 188 +++ 24 files changed, 9365 insertions(+), 1 deletion(-) create mode 100755 smoke/dep_dry_gocart_mod.F90 create mode 100755 smoke/dep_dry_mod.F90 create mode 100755 smoke/dep_simple_mod.F90 create mode 100755 smoke/dep_vertmx_mod.F90 create mode 100755 smoke/dep_wet_ls_mod.F90 create mode 100755 smoke/dust_data_mod.F90 create mode 100755 smoke/dust_fengsha_mod.F90 create mode 100755 smoke/module_add_emiss_burn.F90 create mode 100755 smoke/module_plumerise1.F90 create mode 100755 smoke/module_smoke_plumerise.F90 create mode 100755 smoke/module_zero_plumegen_coms.F90 create mode 100755 smoke/plume_data_mod.F90 delete mode 100644 smoke/readme create mode 100755 smoke/rrfs_smoke_config.F90 create mode 100755 smoke/rrfs_smoke_data.F90 create mode 100644 smoke/rrfs_smoke_lsdep_wrapper.F90 create mode 100755 smoke/rrfs_smoke_lsdep_wrapper.meta create mode 100755 smoke/rrfs_smoke_postpbl.F90 create mode 100755 smoke/rrfs_smoke_postpbl.meta create mode 100755 smoke/rrfs_smoke_wrapper.F90 create mode 100755 smoke/rrfs_smoke_wrapper.meta create mode 100755 smoke/seas_data_mod.F90 create mode 100755 smoke/seas_mod.F90 create mode 100755 smoke/seas_ngac_mod.F90 diff --git a/smoke/dep_dry_gocart_mod.F90 b/smoke/dep_dry_gocart_mod.F90 new file mode 100755 index 000000000..6e15f2e57 --- /dev/null +++ b/smoke/dep_dry_gocart_mod.F90 @@ -0,0 +1,298 @@ +module dep_dry_gocart_mod + + use machine , only : kind_phys + use rrfs_smoke_data + + implicit none + + private + + public :: gocart_drydep_driver + +CONTAINS + +subroutine gocart_drydep_driver(numgas, & + moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & + ivgtyp,tsk,pbl,ust,znt,g, & + num_moist,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + num_moist,num_chem, & + its,ite, jts,jte, kts,kte,numgas + REAL(kind_phys), INTENT(IN ) :: g + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ),& + INTENT(IN ) :: moist + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ) ,& + INTENT(INOUT) :: chem + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) ,& + INTENT(IN ) :: dz8w, p8w,rho_phy + INTEGER, DIMENSION( ims:ime , jms:jme ) ,& + INTENT(IN ) :: ivgtyp + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) ,& + INTENT(INOUT) :: tsk, & + pbl, & + ust, & + xland,znt,hfx + +!! .. Local Scalars .. + + INTEGER :: iland, iprt, iseason, jce, jcs, & + n, nr, ipr, jpr, nvr, & + idrydep_onoff,imx,jmx,lmx + integer :: ii,jj,kk,i,j,k,nv + integer, dimension (1,1) :: ilwi + real(kind_phys), DIMENSION (5) :: tc,bems + real(kind_phys), dimension (1,1) :: z0,w10m,gwet,airden,airmas,& + delz_sfc,hflux,ts,pblz,ustar,& + ps,dvel,drydf + REAL(kind_phys), DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel + + do nv=1,num_chem + do j=jts,jte + do i=its,ite + ddvel(i,j,nv)=0. + enddo + enddo + enddo + imx=1 + jmx=1 + lmx=1 + do j=jts,jte + do i=its,ite + dvel(1,1)=0. + ilwi(1,1)=0 + if(xland(i,j).gt.1.5)ilwi=1 +! for aerosols, ii=1 or ii=2 + ii=1 + if(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.23)ii=1 + airden(1,1)=rho_phy(i,kts,j) + delz_sfc(1,1)=dz8w(i,kts,j) + ustar(1,1)=ust(i,j) + hflux(1,1)=hfx(i,j) + pblz(1,1)=pbl(i,j) + ps(1,1)=p8w(i,kts,j)*.01 + z0(1,1)=znt(i,j) + ts(1,1)=tsk(i,j) + + call depvel_gocart(ii,imx,jmx,lmx,& + airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & + ps, z0, dvel, drydf,g) + do nv=1,num_chem + ddvel(i,j,nv)=dvel(1,1) + enddo + enddo + enddo +end subroutine gocart_drydep_driver + + + +SUBROUTINE depvel_gocart( & + ii,imx,jmx,lmx,& + airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & + ps, z0, dvel, drydf,g0) + +! **************************************************************************** +! * * +! * Calculate dry deposition velocity. * +! * * +! * Input variables: * +! * AEROSOL(k) - Logical, T = aerosol species, F = gas species * +! * IREG(i,j) - # of landtypes in grid square * +! * ILAND(i,j,ldt) - Land type ID for element ldt =1,IREG(i,j) * +! * IUSE(i,j,ldt) - Fraction of gridbox area occupied by land type * +! * element ldt * +! * USTAR(i,j) - Friction velocity (m s-1) * +! * DELZ_SFC(i,j) - Thickness of layer above surface * +! * PBLZ(i,j) - Mixing depth (m) * +! * Z0(i,j) - Roughness height (m) * +! * * +! * Determined in this subroutine (local): * +! * OBK - Monin-Obukhov length (m): set to 1.E5 m under * +! * neutral conditions * +! * Rs(ldt) - Bulk surface resistance(s m-1) for species k to * +! * surface ldt * +! * Ra - Aerodynamic resistance. * +! * Rb - Sublayer resistance. * +! * Rs - Surface resistance. * +! * Rttl - Total deposition resistance (s m-1) for species k * +! * Rttl(k) = Ra + Rb + Rs. * +! * * +! * Returned: * +! * DVEL(i,j,k) - Deposition velocity (m s-1) of species k * +! * DRYDf(i,j,k) - Deposition frequency (s-1) of species k, * +! * = DVEL / DELZ_SFC * +! * * +! **************************************************************************** + + + IMPLICIT NONE + INTEGER, INTENT(IN) :: imx,jmx,lmx + REAL(kind_phys), INTENT(IN) :: airden(imx,jmx), delz_sfc(imx,jmx) + REAL(kind_phys), INTENT(IN) :: hflux(imx,jmx), ts(imx,jmx) + REAL(kind_phys), INTENT(IN) :: ustar(imx,jmx), pblz(imx,jmx) + REAL(kind_phys), INTENT(IN) :: ps(imx,jmx) + INTEGER, INTENT(IN) :: ilwi(imx,jmx) + REAL(kind_phys), INTENT(IN) :: z0(imx,jmx) + REAL(kind=kind_phys), INTENT(IN) :: g0 + REAL(kind_phys), INTENT(OUT) :: dvel(imx,jmx), drydf(imx,jmx) + + REAL(kind_phys) :: obk, vds, czh, rttl, frac, logmfrac, psi_h, cz, eps + REAL(kind_phys) :: vd, ra, rb, rs + INTEGER :: i, j, k, ldt, iolson, ii + CHARACTER(LEN=50) :: msg + REAL(kind_phys) :: prss, tempk, tempc, xnu, ckustr, reyno, aird, diam, xm, z + REAL(kind_phys) :: frpath, speed, dg, dw, rt + REAL(kind_phys) :: rad0, rix, gfact, gfaci, rdc, rixx, rluxx, rgsx, rclx + REAL(kind_phys) :: dtmp1, dtmp2, dtmp3, dtmp4 + REAL(kind_phys) :: biofit,vk + + psi_h=0.0 + ! executable statements + j_loop: DO j = 1,jmx + i_loop: DO i = 1,imx + vk=.4 + vd = 0.0 + ra = 0.0 + rb = 0.0 ! only required for gases (SO2) + rs = 0.0 + +! **************************************************************************** +! * Compute the the Monin-Obhukov length. * +! * The direct computation of the Monin-Obhukov length is: * +! * * +! * - Air density * Cp * T(surface air) * Ustar^3 * +! * OBK = ---------------------------------------------- * +! * vK * g * Sensible Heat flux * +! * * +! * Cp = 1000 J/kg/K = specific heat at constant pressure * +! * vK = 0.4 = von Karman's constant * +! **************************************************************************** + + IF (hflux(i,j) == 0.0) THEN + obk = 1.0E5 + ELSE + ! MINVAL(hflux), MINVAL(airden), MINVAL(ustar) =?? + obk = -airden(i,j) * 1000.0 * ts(i,j) * (ustar(i,j))**3 & + / (vk * g0 * hflux(i,j)) +! -- debug: + IF ( obk == 0.0 ) WRITE(*,211) obk, i, j +211 FORMAT(1X,'OBK=', E11.2, 1X,' i,j = ', 2I4) + + END IF + + cz = delz_sfc(i,j) / 2.0 ! center of the grid box above surface + +! **************************************************************************** +! * (1) Aerosodynamic resistance Ra and sublayer resistance Rb. * +! * * +! * The Reynolds number REYNO diagnoses whether a surface is * +! * aerodynamically rough (REYNO > 10) or smooth. Surface is * +! * rough in all cases except over water with low wind speeds. * +! * * +! * For gas species over land and ice (REYNO >= 10) and for aerosol * +! * species for all surfaces: * +! * * +! * Ra = 1./VT (VT from GEOS Kzz at L=1, m/s). * +! * * +! * The following equations are from Walcek et al, 1986: * +! * * +! * For gas species when REYNO < 10 (smooth), Ra and Rb are combined * +! * as Ra: * +! * * +! * Ra = { ln(ku* z1/Dg) - Sh } / ku* eq.(13) * +! * * +! * where z1 is the altitude at the center of the lowest model layer * +! * (CZ); * +! * Sh is a stability correction function; * +! * k is the von Karman constant (0.4, vK); * +! * u* is the friction velocity (USTAR). * +! * * +! * Sh is computed as a function of z1 and L eq ( 4) and (5)): * +! * * +! * 0 < z1/L <= 1: Sh = -5 * z1/L * +! * z1/L < 0: Sh = exp{ 0.598 + 0.39*ln(E) - 0.09(ln(E))^2 } * +! * where E = min(1,-z1/L) (Balkanski, thesis). * +! * * +! * For gas species when REYNO >= 10, * +! * * +! * Rb = 2/ku* (Dair/Dg)**(2/3) eq.(12) * +! * where Dg is the gas diffusivity, and * +! * Dair is the air diffusivity. * +! * * +! * For aerosol species, Rb is combined with surface resistance as Rs. * +! * * +! **************************************************************************** + + frac = cz / obk + IF (frac > 1.0) frac = 1.0 + IF (frac > 0.0 .AND. frac <= 1.0) THEN + psi_h = -5.0*frac + ELSE IF (frac < 0.0) THEN + eps = MIN(1.0D0, -frac) + logmfrac = LOG(eps) + psi_h = EXP( 0.598 + 0.39 * logmfrac - 0.09 * (logmfrac)**2 ) + END IF + !-------------------------------------------------------------- + ! Aerosol species, Rs here is the combination of Rb and Rs. + + ra = (LOG(cz/z0(i,j)) - psi_h) / (vk*ustar(i,j)) + + vds = 0.002*ustar(i,j) + IF (obk < 0.0) & + vds = vds * (1.0+(-300.0/obk)**0.6667) + + czh = pblz(i,j)/obk + IF (czh < -30.0) vds = 0.0009*ustar(i,j)*(-czh)**0.6667 + + ! --Set Vds to be less than VDSMAX (entry in input file divided -- + ! by 1.E4). VDSMAX is taken from Table 2 of Walcek et al. [1986]. + ! Invert to get corresponding R + if(ii.eq.1)then + rs=1.0/MIN(vds,2.0D-2) + else + rs=1.0/MIN(vds,2.0D-3) + endif + + + ! ------ Set max and min values for bulk surface resistances ------ + + rs= MAX(1.0D0, MIN(rs, 9.9990D+3)) + +! **************************************************************************** +! * * +! * Compute dry deposition velocity. * +! * * +! * IUSE is the fraction of the grid square occupied by surface ldt in * +! * units of per mil (IUSE=500 -> 50% of the grid square). Add the * +! * contribution of surface type ldt to the deposition velocity; this is * +! * a loop over all surface types in the gridbox. * +! * * +! * Total resistance = Ra + Rb + Rs. +! * * +! **************************************************************************** + + rttl = ra + rb + rs + vd = vd + 1./rttl + + ! ------ Load array DVEL ------ + dvel(i,j) = vd * 1.2 + + ! -- Set a minimum value for DVEL + ! MIN(VdSO2) = 2.0e-3 m/s over ice + ! = 3.0e-3 m/s over land + ! MIN(vd_aerosol) = 1.0e-4 m/s + + IF (dvel(i,j) < 1.0E-4) dvel(i,j) = 1.0E-4 + drydf(i,j) = dvel(i,j) / delz_sfc(i,j) + + END DO i_loop + END DO j_loop + +END SUBROUTINE depvel_gocart + +end module dep_dry_gocart_mod diff --git a/smoke/dep_dry_mod.F90 b/smoke/dep_dry_mod.F90 new file mode 100755 index 000000000..140db6002 --- /dev/null +++ b/smoke/dep_dry_mod.F90 @@ -0,0 +1,300 @@ +module dep_dry_mod + + use machine , only : kind_phys + use rrfs_smoke_config, only : epsilc, GOCART_SIMPLE => CHEM_OPT_GOCART, CTRA_OPT_NONE +! use chem_tracers_mod, only : p_o3,p_dust_1,p_vash_1,p_vash_4,p_vash_10,p_dms, +! & +! config_flags => chem_config + use dep_dry_gocart_mod + use dep_simple_mod + use dep_vertmx_mod +! use aero_soa_vbs_mod, only : soa_vbs_depdriver + + implicit none + + + private + + public :: dry_dep_driver + +contains + + subroutine dry_dep_driver(data,ktau,dtstep,julday,current_month,t_phy,p_phy, & + moist,p8w,rmol,alt,gmt,t8w,raincv, & + chem,rho_phy,dz8w,exch_h,hfx, & + ivgtyp,tsk,gsw,vegfra,pbl,ust,znt,z,z_at_w, & + xland,xlat,xlong,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & + anh3,ddep,dep_vel_o3,g, & + e_co,kemit,snowh,numgas, & + num_chem,num_moist, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- +! USE module_model_constants +! USE module_configure +! USE module_state_description +! USE module_dep_simple +! USE module_initial_chem_namelists,only:p_o3,p_dust_1,p_vash_1,p_vash_4,p_vash_10,p_dms +! USE module_vertmx_wrf +! USE module_chemvars,only:epsilc +! USE module_data_sorgam +! USE module_aerosols_sorgam +! USE module_gocart_settling +! use module_dep_simple +! USE module_gocart_drydep,only: gocart_drydep_driver +! USE module_aerosols_soa_vbs, only: soa_vbs_depdriver +! USE module_mosaic_drydep, only: mosaic_drydep_driver +! USE module_mixactivate_wrappers, only: mosaic_mixactivate, sorgam_mixactivate + IMPLICIT NONE + type(smoke_data), pointer, intent(inout) :: data + + INTEGER, INTENT(IN ) :: numgas, current_month, & + num_chem,num_moist, julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + + INTEGER, INTENT(IN ) :: kemit + REAL(kind_phys), DIMENSION( ims:ime, kms:kemit, jms:jme ), & + INTENT(IN ) :: & + e_co + + + + + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t8w, & + dz8w, & + p8w,z_at_w , & + exch_h,rho_phy,z + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3 + INTEGER,DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + ivgtyp + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: & + tsk, & + gsw, & + vegfra, & + pbl, & + snowh, & + raincv, & + ust, & + hfx, & + xland, & + xlat, & + xlong, & + znt,rmol + REAL(kind_phys), DIMENSION( ims:ime, jms:jme, num_chem ), & + INTENT(OUT ) :: ddep + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(OUT) :: & + dep_vel_o3 + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + p_phy, & + t_phy + + REAL(kind_phys), INTENT(IN ) :: & + dtstep,g,gmt + +!--- deposition and emissions stuff +! .. Parameters .. +! .. +! .. Local Scalars .. + + REAL(kind_phys) :: cdt, factor + + INTEGER :: idrydep_onoff + +! INTEGER :: chem_conv_tr, chem_opt + +! CHARACTER (4) :: luse_typ,mminlu_loc +! .. +! .. Local Arrays .. + REAL(kind_phys), DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel + +! REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) :: dryrho_phy + REAL(kind_phys), DIMENSION( kts:kte ) :: dryrho_1d + +! turbulent transport + real(kind_phys) :: pblst(kts:kte),ekmfull(kts:kte+1),zzfull(kts:kte+1),zz(kts:kte) + integer :: i,j,k,nv +! +! necessary for aerosols (module dependent) +! + REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res + REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res_def + REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res_zcen + +! .. +! .. Intrinsic Functions .. + INTRINSIC max, min + +! chem_opt = chem_opt +! chem_conv_tr = chem_conv_tr + +! +! compute dry deposition velocities = ddvel +! +! 28-jun-2005 rce - initialize ddvel=0; call aerosol drydep routine +! only when drydep_opt == WESELY +! the wesely_driver routine computes aer_res, and currently +! you cannot compute aerosol drydep without it !! +! 08-jul-2005 rce - pass idrydep_onoff to mixactivate routines +! +! write(6,*)'call dry dep driver' + dep_vel_o3(:,:)=0. + ddvel(:,:,:) = 0.0 + idrydep_onoff = 0 + +! drydep_select: SELECT CASE(drydep_opt) + +! CASE ( WESELY ) +! +! drydep_opt == WESELY means +! wesely for gases +! other (appropriate) routine for aerosols +! +! CALL wrf_debug(15,'DOING DRY DEP VELOCITIES WITH WESELY METHOD') + + IF( chem_opt /= GOCART_SIMPLE ) THEN + call wesely_driver(data,ktau,dtstep, & + current_month, & + gmt,julday,t_phy,moist,p8w,t8w,raincv, & + p_phy,chem,rho_phy,dz8w,ddvel,aer_res_def,aer_res_zcen, & + ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& + snowh,numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ENDIF + IF (( chem_opt == GOCART_SIMPLE ) .or. & + ( chem_opt == GOCARTRACM_KPP) .or. & + ( chem_opt == 316) .or. & + ( chem_opt == 317) .or. & +! ( chem_opt == 502) .or. & + (chem_opt == 304 )) then +! +! this does aerosol species (dust,seas, bc,oc) for gocart only +! this does aerosol species (dust,seas, bc,oc,sulf) for gocart only +!, + call gocart_drydep_driver(numgas, & + moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & + ivgtyp,tsk,pbl,ust,znt,g, & + num_moist,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ELSE if (chem_opt == 501 ) then +! for caesium .1cm/s +! + ddvel(:,:,:)=.001 + ELSE if (chem_opt == 108 ) then +!! call soa_vbs_depdriver (ust,t_phy, & +!! moist,p8w,rmol,znt,pbl, & +!! alt,p_phy,chem,rho_phy,dz8w, & +!! h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, & +!! aer_res,ddvel(:,:,numgas+1:num_chem), & +!! num_chem-numgas, & +!! ids,ide, jds,jde, kds,kde, & +!! ims,ime, jms,jme, kms,kme, & +!! its,ite, jts,jte, kts,kte ) +! limit aerosol ddvels to <= 0.5 m/s +! drydep routines occasionally produce unrealistically-large particle +! diameter leading to unrealistically-large sedimentation velocity + ddvel(:,:,numgas+1:num_chem) = min( 0.50, ddvel(:,:,numgas+1:num_chem)) + ELSE + !Set dry deposition velocity to zero when using the + !chemistry tracer mode. + ddvel(:,:,:) = 0. + END IF + idrydep_onoff = 1 + +! +! Compute dry deposition according to NGAC +! + cdt = real(dtstep, kind=kind_phys) + do nv = 1, num_chem + do j = jts, jte + do i = its, ite + factor = 1._kind_phys - exp(-ddvel(i,j,nv)*cdt/dz8w(i,kts,j)) + ddep(i,j,nv) = max(0.0, factor * chem(i,kts,j,nv)) & !ug/m2/s + * (p8w(i,kts,j)-p8w(i,kts+1,j))/g/dtstep + end do + end do + end do + + +! This will be called later from subgrd_transport_driver.F !!!!!!!! +! +! + do 100 j=jts,jte + do 100 i=its,ite + if(p_dust_1.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_dust_1) + pblst=0. +! +! +!-- start with vertical mixing +! + do k=kts,kte+1 + zzfull(k)=z_at_w(i,k,j)-z_at_w(i,kts,j) + enddo + + if (chem_conv_tr == CTRA_OPT_NONE) then + ekmfull = 0. + else + ekmfull(kts)=0. + do k=kts+1,kte + ekmfull(k)=max(1.e-6,exch_h(i,k,j)) + enddo + ekmfull(kte+1)=0. + end if + +!!$! UNCOMMENT THIS AND FINE TUNE LEVELS TO YOUR DOMAIN IF YOU WANT TO +!!$! FORCE MIXING TO A CERTAIN DEPTH: +!!$! +!!$! --- Mix the emissions up several layers +! + do k=kts,kte + zz(k)=z(i,k,j)-z_at_w(i,kts,j) + enddo +! vertical mixing routine (including deposition) +! need to be careful here with that dumm tracer in spot 1 +! do not need lho,lho2 +! (03-may-2006 rce - calc dryrho_1d and pass it to vertmx) +! +! if(p_o3.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_o3) + do nv=1,num_chem-0 + do k=kts,kte + pblst(k)=max(epsilc,chem(i,k,j,nv)) + dryrho_1d(k) = 1./alt(i,k,j) + enddo + + !mix_select: SELECT CASE(chem_opt) + !CASE DEFAULT + call vertmx(data,dtstep,pblst,ekmfull,dryrho_1d, & + zzfull,zz,ddvel(i,j,nv),kts,kte) + + !END SELECT mix_select + + do k=kts,kte + chem(i,k,j,nv)=max(epsilc,pblst(k)) + enddo + enddo +100 continue + +END SUBROUTINE dry_dep_driver + +end module dep_dry_mod diff --git a/smoke/dep_simple_mod.F90 b/smoke/dep_simple_mod.F90 new file mode 100755 index 000000000..9751b19a6 --- /dev/null +++ b/smoke/dep_simple_mod.F90 @@ -0,0 +1,763 @@ +module dep_simple_mod + + use rrfs_smoke_data + use rrfs_smoke_config, GOCART_SIMPLE => CHEM_OPT_GOCART, chem_opt=>chem_opt +! use chem_tracers_mod, config_flags => chem_config + +! USE module_data_sorgam + + implicit none + +!-------------------------------------------------- +! .. Default Accessibility .. +!-------------------------------------------------- + PUBLIC + + + CONTAINS + +SUBROUTINE wesely_driver( data, ktau, dtstep, current_month, & + gmt, julday, t_phy,moist, p8w, t8w, raincv, & + p_phy, chem, rho_phy, dz8w, ddvel, aer_res_def, & + aer_res_zcen, ivgtyp, tsk, gsw, vegfra, pbl, & + rmol, ust, znt, xlat, xlong, & + z, z_at_w, snowh, numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + implicit none +!-------------------------------------------------- +! Wesely dry dposition driver +!-------------------------------------------------- + +! USE module_model_constants +! USE module_wrf_control,only:num_moist,num_chem +! USE module_state_description +! USE module_initial_chem_namelists +! USE module_data_sorgam +! USE module_state_description, only: param_first_scalar + type(smoke_data), intent(inout), pointer :: data + INTEGER, INTENT(IN ) :: julday, & + numgas, current_month, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: ktau + REAL(kind_phys), INTENT(IN ) :: dtstep,gmt + +!-------------------------------------------------- +! advected moisture variables +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), INTENT(IN ) :: & + moist +!-------------------------------------------------- +! advected chemical species +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT ) :: & + chem +!-------------------------------------------------- +! deposition velocities +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( its:ite, jts:jte, num_chem ), INTENT(INOUT ) :: & + ddvel +!-------------------------------------------------- +! input from met model +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + z, & + t8w, & + p8w, & + z_at_w, & + rho_phy + INTEGER,DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: & + ivgtyp + REAL(KIND_PHYS), DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ) :: & + tsk, & + gsw, & + vegfra, & + pbl, & + rmol, & + ust, & + xlat, & + xlong, & + raincv, & + znt + REAL(KIND_PHYS), intent(inout) :: aer_res_def(its:ite,jts:jte) + REAL(KIND_PHYS), intent(inout) :: aer_res_zcen(its:ite,jts:jte) + REAL(KIND_PHYS), INTENT(IN) :: snowh(ims:ime,jms:jme) + +!-------------------------------------------------- +! .. Local Scalars +!-------------------------------------------------- + REAL(kind_phys) :: clwchem, dvfog, dvpart, pa, rad, dep_vap + REAL(KIND_PHYS) :: rhchem, ta, ustar, vegfrac, z1, zntt + INTEGER :: i, iland, iprt, iseason, j, jce, jcs, n, nr, ipr,jpr,nvr + LOGICAL :: highnh3, rainflag, vegflag, wetflag +!-------------------------------------------------- +! .. Local Arrays +!-------------------------------------------------- + REAL(KIND_PHYS) :: p(kts:kte) + REAL(KIND_PHYS) :: srfres(numgas) + REAL(KIND_PHYS) :: ddvel0d(numgas) + +!----------------------------------------------------------- +! necessary for aerosols (module dependent) +!----------------------------------------------------------- + real(kind_phys) :: rcx(numgas) + + +!----------------------------------------------------------- +! .. Intrinsic Functions +!----------------------------------------------------------- +! integer :: chem_opt + + INTRINSIC max, min + + data => get_thread_smoke_data() + +! chem_opt = chem_opt + + dep_vap = depo_fact + !print*,'hli simple chem_opt',chem_opt + +! CALL wrf_debug(15,'in dry_dep_wesely') + + if( julday < 90 .or. julday > 270 ) then + iseason = 2 +! CALL wrf_debug(15,'setting iseason to 2') + else + iseason = 1 + endif + + +tile_lat_loop : & + do j = jts,jte +tile_lon_loop : & + do i = its,ite + iprt = 0 + + iland = luse2usgs( ivgtyp(i,j) ) +!-- + + ta = tsk(i,j) + rad = gsw(i,j) + vegfrac = vegfra(i,j) + pa = .01*p_phy(i,kts,j) + clwchem = moist(i,kts,j,p_qc) + ustar = ust(i,j) + zntt = znt(i,j) + z1 = z_at_w(i,kts+1,j) - z_at_w(i,kts,j) +!----------------------------------------------------------- +! Set logical default values +!----------------------------------------------------------- + rainflag = .FALSE. + wetflag = .FALSE. + highnh3 = .FALSE. +! if(p_qr > 1) then +! if(moist(i,kts,j,p_qr) > 1.e-18 .or. raincv(i,j) > 0.) then +! rainflag = .true. +! endif +! endif + rhchem = MIN( 100.,100. * moist(i,kts,j,p_qv) / & + (3.80*exp(17.27*(t_phy(i,kts,j)-273.)/(t_phy(i,kts,j)-36.))/pa)) + rhchem = MAX(5.,RHCHEM) + if (rhchem >= 95.) wetflag = .true. + +!----------------------------------------------------------- +!--- deposition +!----------------------------------------------------------- +! if(snowc(i,j).gt.0.)iseason=4 + CALL rc( data, rcx, ta, rad, rhchem, iland, & + iseason, numgas, wetflag, rainflag, highnh3, & + iprt, moist(i,kts,j,p_qv), p8w(i,kts,j) ) + srfres(1:numgas-2) = rcx(1:numgas-2) + srfres(numgas-1:numgas) = 0. + CALL deppart( data, rmol(i,j), ustar, rhchem, clwchem, iland, dvpart, dvfog ) + ddvel0d(1:numgas) = 0. + aer_res_def(i,j) = 0. + aer_res_zcen(i,j) = 0. + CALL landusevg( data, ddvel0d, ustar, rmol(i,j), zntt, z1, dvpart, iland, & + numgas, srfres, aer_res_def(i,j), aer_res_zcen(i,j), p_sulf ) + +!----------------------------------------------------------- +!wig: CBMZ does not have HO and HO2 last so need to copy all species +! ddvel(i,j,1:numgas-2)=ddvel0d(1:numgas-2) +!----------------------------------------------------------- + ddvel(i,j,1:numgas) = ddvel0d(1:numgas) + end do tile_lon_loop + end do tile_lat_loop + +!----------------------------------------------------------- +! For the additional CBMZ species, assign similar RADM counter parts for +! now. Short lived species get a zero velocity since dry dep should be +! unimportant. **ALSO**, treat p_sulf as h2so4 vapor, not aerosol sulfate +!----------------------------------------------------------- +! + +!----------------------------------------------------------- +! For gocartsimple : need msa. On the other hand sulf comes from aerosol routine +!----------------------------------------------------------- + if (chem_opt == GOCART_SIMPLE ) then + do j=jts,jte + do i=its,ite + ddvel(i,j,p_msa) = ddvel(i,j,p_sulf) + ddvel(i,j,p_sulf) = 0. + ddvel(i,j,p_dms) = 0. + end do + end do + end if + +END SUBROUTINE wesely_driver + + SUBROUTINE rc( data, rcx, t, rad, rh, iland, & + iseason, numgas, wetflag, rainflag, highnh3, & + iprt, spec_hum, p_srf ) +!---------------------------------------------------------------------- +! THIS SUBROUTINE CALCULATES SURFACE RESISTENCES ACCORDING +! TO THE MODEL OF +! M. L. WESELY, +! ATMOSPHERIC ENVIRONMENT 23 (1989), 1293-1304 +! WITH SOME ADDITIONS ACCORDING TO +! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 +! WRITTEN BY WINFRIED SEIDL, APRIL 1997 +! MODYFIED BY WINFRIED SEIDL, MARCH 2000 +! FOR MM5 VERSION 3 +!---------------------------------------------------------------------- + +! USE module_state_description +! USE module_initial_chem_namelists + implicit none + type(smoke_data), pointer, intent(inout) :: data +!---------------------------------------------------------------------- +! ... dummy arguments +!---------------------------------------------------------------------- + INTEGER, intent(in) :: iland, iseason, numgas + INTEGER, intent(in) :: iprt + REAL(KIND_PHYS), intent(in) :: rad, rh + REAL(KIND_PHYS), intent(in) :: t ! surface temp (K) + REAL(KIND_PHYS), intent(in) :: p_srf ! surface pressure (Pa) + REAL(KIND_PHYS), intent(in) :: spec_hum ! surface specific humidity (kg/kg) + real(kind_phys), intent(out) :: rcx(numgas) + LOGICAL, intent(in) :: highnh3, rainflag, wetflag + +!---------------------------------------------------------------------- +! .. Local Scalars .. +!---------------------------------------------------------------------- + REAL(KIND_PHYS), parameter :: t0 = 298. + REAL(KIND_PHYS), parameter :: tmelt = 273.16 + INTEGER :: lt, n + INTEGER :: chem_opt + REAL(KIND_PHYS) :: rclx, rdc, resice, rgsx, rluo1, rluo2 + REAL(KIND_PHYS) :: rlux, rmx, rs, rsmx, rdtheta, z, wrk + REAL(KIND_PHYS) :: qs, es, ws, dewm, dv_pan, drat + REAL(KIND_PHYS) :: crs, tc + REAL(KIND_PHYS) :: rs_pan, tc_pan + LOGICAL :: has_dew +!---------------------------------------------------------------------- +! .. Local Arrays .. +!---------------------------------------------------------------------- + REAL(KIND_PHYS) :: hstary(numgas) + +!---------------------------------------------------------------------- +! .. Intrinsic Functions .. +!---------------------------------------------------------------------- + INTRINSIC exp + + chem_opt = chem_opt + + rcx(1:numgas) = 1. + + tc = t - 273.15 + rdtheta = 0. + + z = 200./(rad+0.1) + +!!! HARDWIRE VALUES FOR TESTING +! z=0.4727409 +! tc=22.76083 +! t=tc+273.15 +! rad = 412.8426 +! rainflag=.false. +! wetflag=.false. + + IF ( tc<=0. .OR. tc>=40. ) THEN + rs = 9999. + ELSE + rs = data%ri(iland,iseason)*(1+z*z)*(400./(tc*(40.-tc))) + END IF + rdc = 100.*(1. + 1000./(rad + 10.))/(1. + 1000.*rdtheta) + rluo1 = 1./(1./3000. + 3./data%rlu(iland,iseason)) + rluo2 = 1./(1./1000. + 3./data%rlu(iland,iseason)) + resice = 1000.*exp( -(tc + 4.) ) + wrk = (t0 - t)/(t0*t) + + + DO n = 1, numgas + IF( data%hstar(n) /= 0. ) then + hstary(n) = data%hstar(n)*exp( data%dhr(n)*wrk ) +!---------------------------------------------------------------------- +! SPECIAL TREATMENT FOR HNO3, HNO4, H2O2, PAA +!---------------------------------------------------------------------- + rmx = 1./(hstary(n)/3000. + 100.*data%f0(n)) + rsmx = rs*data%dratio(n) + rmx + rclx = 1./(1.e-5*hstary(n)/data%rcls(iland,iseason) & + + data%f0(n)/data%rclo(iland,iseason)) + resice + rgsx = 1./(1.e-5*hstary(n)/data%rgss(iland,iseason) & + + data%f0(n)/data%rgso(iland,iseason)) + resice + rlux = data%rlu(iland,iseason)/(1.e-5*hstary(n) + data%f0(n)) + resice + IF( wetflag ) THEN + rlux = 1./(1./(3.*data%rlu(iland,iseason)) + 1.e-7*hstary(n) + data%f0(n)/rluo1) + END IF + IF( rainflag ) THEN + rlux = 1./(1./(3.*data%rlu(iland,iseason)) + 1.e-7*hstary(n) + data%f0(n)/rluo2) + END IF + rcx(n) = 1./(1./rsmx + 1./rlux + 1./(rdc + rclx) + 1./(data%rac(iland,iseason) + rgsx)) + rcx(n) = max( 1.,rcx(n) ) + end IF + END DO + +!-------------------------------------------------- +! SPECIAL TREATMENT FOR OZONE +!-------------------------------------------------- +! SPECIAL TREATMENT FOR SO2 (Wesely) +! HSTARY(P_SO2)=DATA%HSTAR(P_SO2)*EXP(DATA%DHR(P_SO2)*(1./T-1./298.)) +! RMX=1./(HSTARY(P_SO2)/3000.+100.*DATA%F0(P_SO2)) +! RSMX=RS*DATA%DRATIO(P_SO2)+RMX +! RLUX=DATA%RLU(ILAND,ISEASON)/(1.E-5*HSTARY(P_SO2)+DATA%F0(P_SO2)) +! & +RESICE +! RCLX=DATA%RCLS(ILAND,ISEASON)+RESICE +! RGSX=DATA%RGSS(ILAND,ISEASON)+RESICE +! IF ((wetflag).OR.(RAINFLAG)) THEN +! IF (ILAND.EQ.1) THEN +! RLUX=50. +! ELSE +! RLUX=100. +! END IF +! END IF +! RCX(P_SO2)=1./(1./RSMX+1./RLUX+1./(RDC+RCLX) +! & +1./(DATA%RAC(ILAND,ISEASON)+RGSX)) +! IF (RCX(P_SO2).LT.1.) RCX(P_SO2)=1. + +!-------------------------------------------------- +! SO2 according to Erisman et al. 1994 +! R_STOM +!-------------------------------------------------- +is_so2 : & + if( p_so2 > 1 ) then + rsmx = rs*data%dratio(p_so2) +!-------------------------------------------------- +! R_EXT +!-------------------------------------------------- + IF (tc> -1. ) THEN + IF (rh<81.3) THEN + rlux = 25000.*exp(-0.0693*rh) + ELSE + rlux = 0.58E12*exp(-0.278*rh) + END IF + END IF + IF (((wetflag) .OR. (rainflag)) .AND. (tc> -1. )) THEN + rlux = 1. + END IF + IF ((tc>= -5. ) .AND. (tc<= -1. )) THEN + rlux = 200. + END IF + IF (tc< -5. ) THEN + rlux = 500. + END IF +!-------------------------------------------------- +! INSTEAD OF R_INC R_CL and R_DC of Wesely are used +!-------------------------------------------------- + rclx = data%rcls(iland,iseason) +!-------------------------------------------------- +! DRY SURFACE +!-------------------------------------------------- + rgsx = 1000. +!-------------------------------------------------- +! WET SURFACE +!-------------------------------------------------- + IF ((wetflag) .OR. (rainflag)) THEN + IF (highnh3) THEN + rgsx = 0. + ELSE + rgsx = 500. + END IF + END IF +!-------------------------------------------------- +! WATER +!-------------------------------------------------- + IF (iland==iswater_temp) THEN + rgsx = 0. + END IF +!-------------------------------------------------- +! SNOW +!-------------------------------------------------- + IF( iseason==4 .OR. iland==isice_temp ) THEN + IF( tc > 2. ) THEN + rgsx = 0. + else IF ( tc >= -1. .AND. tc <= 2. ) THEN + rgsx = 70.*(2. - tc) + else IF ( tc < -1. ) THEN + rgsx = 500. + END IF + END IF +!-------------------------------------------------- +! TOTAL SURFACE RESISTENCE +!-------------------------------------------------- + IF ((iseason/=4) .AND. (data%ixxxlu(iland)/=1) .AND. (iland/=iswater_temp) .AND. & + (iland/=isice_temp)) THEN + rcx(p_so2) = 1./(1./rsmx+1./rlux+1./(rclx+rdc+rgsx)) + ELSE + rcx(p_so2) = rgsx + END IF + rcx(p_so2) = max( 1.,rcx(p_so2) ) + end if is_so2 +!-------------------------------------------------- +! NH3 according to Erisman et al. 1994 +! R_STOM +!-------------------------------------------------- + END SUBROUTINE rc + + SUBROUTINE deppart( data, rmol, ustar, rh, clw, iland, & + dvpart, dvfog ) +!-------------------------------------------------- +! THIS SUBROUTINE CALCULATES SURFACE DEPOSITION VELOCITIES +! FOR FINE AEROSOL PARTICLES ACCORDING TO THE MODEL OF +! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 +! WRITTEN BY WINFRIED SEIDL, APRIL 1997 +! MODIFIED BY WINFRIED SEIDL, MARCH 2000 +! FOR MM5 VERSION 3 +!-------------------------------------------------- + implicit none + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: iland + REAL(KIND_PHYS), intent(in) :: clw, rh, rmol, ustar + REAL(KIND_PHYS), intent(out) :: dvfog, dvpart + +!-------------------------------------------------- +! .. Intrinsic Functions .. +!-------------------------------------------------- + INTRINSIC exp + + dvpart = ustar/data%kpart(iland) + IF (rmol<0.) THEN +!-------------------------------------------------- +! UNSTABLE LAYERING CORRECTION +!-------------------------------------------------- + dvpart = dvpart*(1.+(-300.*rmol)**0.66667) + END IF + IF (rh>80.) THEN +!-------------------------------------------------- +! HIGH RELATIVE HUMIDITY CORRECTION +! ACCORDING TO J. W. ERISMAN ET AL. +! ATMOSPHERIC ENVIRONMENT 31 (1997), 321-332 +!-------------------------------------------------- + dvpart = dvpart*(1.+0.37*exp((rh-80.)/20.)) + END IF + +!-------------------------------------------------- +! SEDIMENTATION VELOCITY OF FOG WATER ACCORDING TO +! R. FORKEL, W. SEIDL, R. DLUGI AND E. DEIGELE +! J. GEOPHYS. RES. 95D (1990), 18501-18515 +!-------------------------------------------------- + dvfog = 0.06*clw + IF (data%ixxxlu(iland)==5) THEN +!-------------------------------------------------- +! TURBULENT DEPOSITION OF FOG WATER IN CONIFEROUS FOREST ACCORDI +! A. T. VERMEULEN ET AL. +! ATMOSPHERIC ENVIRONMENT 31 (1997), 375-386 +!-------------------------------------------------- + dvfog = dvfog + 0.195*ustar*ustar + END IF + + END SUBROUTINE deppart + + SUBROUTINE landusevg( data, vgs, ustar, rmol, z0, zz, & + dvparx, iland, numgas, srfres, aer_res_def, & + aer_res_zcen, p_sulf ) +!-------------------------------------------------- +! This subroutine calculates the species specific deposition velocit +! as a function of the local meteorology and land use. The depositi +! Velocity is also landuse specific. +! Reference: Hsieh, C.M., Wesely, M.L. and Walcek, C.J. (1986) +! A Dry Deposition Module for Regional Acid Deposition +! EPA report under agreement DW89930060-01 +! Revised version by Darrell Winner (January 1991) +! Environmental Engineering Science 138-78 +! California Institute of Technology +! Pasadena, CA 91125 +! Modified by Winfried Seidl (August 1997) +! Fraunhofer-Institut fuer Atmosphaerische Umweltforschung +! Garmisch-Partenkirchen, D-82467 +! for use of Wesely and Erisman surface resistances +! Inputs: +! Ustar : The grid average friction velocity (m/s) +! Rmol : Reciprocal of the Monin-Obukhov length (1/m) +! Z0 : Surface roughness height for the grid square (m) +! SrfRes : Array of landuse/atmospheric/species resistances (s/m) +! Slist : Array of chemical species codes +! Dvparx : Array of surface deposition velocity of fine aerosol p +! Outputs: +! Vgs : Array of species and landuse specific deposition +! velocities (m/s) +! Vg : Cell-average deposition velocity by species (m/s) +! Variables used: +! SCPR23 : (Schmidt #/Prandtl #)**(2/3) Diffusion correction fac +! Zr : Reference Height (m) +! Iatmo : Parameter specifying the stabilty class (Function of +! Z0 : Surface roughness height (m) +! karman : Von Karman constant (from module_model_constants) +!-------------------------------------------------- + +! USE module_model_constants, only: karman + implicit none + + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: iland, numgas, p_sulf + REAL(KIND_PHYS), intent(in) :: dvparx, ustar, z0, zz + REAL(KIND_PHYS), intent(inout) :: rmol + REAL(KIND_PHYS), intent(inout) :: aer_res_def + REAL(KIND_PHYS), intent(inout) :: aer_res_zcen +!-------------------------------------------------- +! .. Array Arguments .. +!-------------------------------------------------- + REAL(KIND_PHYS), intent(in) :: srfres(numgas) + REAL(KIND_PHYS), intent(out) :: vgs(numgas) + +!-------------------------------------------------- +! .. Local Scalars .. +!-------------------------------------------------- + INTEGER :: jspec + REAL(KIND_PHYS) :: vgp, vgpart, zr + REAL(KIND_PHYS) :: rmol_tmp +!-------------------------------------------------- +! .. Local Arrays .. +!-------------------------------------------------- + REAL(KIND_PHYS) :: vgspec(numgas) + +!-------------------------------------------------- +! Calculate aerodynamic resistance for reference +! height = layer center +!-------------------------------------------------- + zr = zz*.5 + rmol_tmp = rmol + CALL depvel( data, numgas, rmol_tmp, zr, z0, ustar, & + vgspec, vgpart, aer_res_zcen ) +!-------------------------------------------------- +! Set the reference height (2.0 m) +!-------------------------------------------------- +! zr = 10.0 + zr = 2.0 + +!-------------------------------------------------- +! CALCULATE THE DEPOSITION VELOCITY without any surface +! resistance term, i.e. 1 / (ra + rb) +!-------------------------------------------------- + CALL depvel( data, numgas, rmol, zr, z0, ustar, & + vgspec, vgpart, aer_res_def ) + +!-------------------------------------------------- +! Calculate the deposition velocity for each species +! and grid cell by looping through all the possibile combinations +! of the two +!-------------------------------------------------- + vgp = 1.0/((1.0/vgpart)+(1.0/dvparx)) +!-------------------------------------------------- +! Loop through the various species +!-------------------------------------------------- + DO jspec = 1, numgas +!-------------------------------------------------- +! Add in the surface resistance term, rc (SrfRes) +!-------------------------------------------------- + vgs(jspec) = 1.0/(1.0/vgspec(jspec) + srfres(jspec)) + END DO + vgs(p_sulf) = vgp + + CALL cellvg( data, vgs, ustar, zz, zr, rmol, numgas ) + + END SUBROUTINE landusevg + + SUBROUTINE cellvg( data, vgtemp, ustar, dz, zr, rmol, nspec ) +!-------------------------------------------------- +! THIS PROGRAM HAS BEEN DESIGNED TO CALCULATE THE CELL AVERAGE +! DEPOSITION VELOCITY GIVEN THE VALUE OF VG AT SOME REFERENCE +! HEIGHT ZR WHICH IS MUCH SMALLER THAN THE CELL HEIGHT DZ. +! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) +! Modified by Darrell A. Winner (February 1991) +!.....PROGRAM VARIABLES... +! VgTemp - DEPOSITION VELOCITY AT THE REFERENCE HEIGHT +! USTAR - FRICTION VELOCITY +! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH +! ZR - REFERENCE HEIGHT +! DZ - CELL HEIGHT +! CELLVG - CELL AVERAGE DEPOSITION VELOCITY +! VK - VON KARMAN CONSTANT +!-------------------------------------------------- + +! USE module_model_constants, only: karman + implicit none + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: nspec + REAL(KIND_PHYS), intent(in) :: dz, rmol, ustar, zr +!-------------------------------------------------- +! .. Array Arguments .. +!-------------------------------------------------- + REAL(KIND_PHYS), intent(out) :: vgtemp(nspec) +!-------------------------------------------------- +! .. Local Scalars .. +!-------------------------------------------------- + INTEGER :: nss + REAL(KIND_PHYS) :: a, fac, pdz, pzr, vk +!-------------------------------------------------- +! .. Intrinsic Functions .. +!-------------------------------------------------- + INTRINSIC alog, sqrt + +!-------------------------------------------------- +! Set the von Karman constant +!-------------------------------------------------- + vk = karman + +!-------------------------------------------------- +! DETERMINE THE STABILITY BASED ON THE CONDITIONS +! 1/L < 0 UNSTABLE +! 1/L = 0 NEUTRAL +! 1/L > 0 STABLE +!-------------------------------------------------- + DO nss = 1, nspec + IF (rmol < 0.) THEN + pdz = sqrt(1.0 - 9.0*dz*rmol) + pzr = sqrt(1.0 - 9.0*zr*rmol) + fac = ((pdz - 1.0)/(pzr - 1.0))*((pzr + 1.0)/(pdz + 1.0)) + a = 0.74*dz*alog(fac) + (0.164/rmol)*(pdz-pzr) + ELSE IF (rmol == 0.) THEN + a = 0.74*(dz*alog(dz/zr) - dz + zr) + ELSE + a = 0.74*(dz*alog(dz/zr) - dz + zr) + (2.35*rmol)*(dz - zr)**2 + END IF +!-------------------------------------------------- +! CALCULATE THE DEPOSITION VELOCITIY +!-------------------------------------------------- + vgtemp(nss) = vgtemp(nss)/(1.0 + vgtemp(nss)*a/(vk*ustar*(dz - zr))) + END DO + + END SUBROUTINE cellvg + + SUBROUTINE depvel( data, numgas, rmol, zr, z0, ustar, & + depv, vgpart, aer_res ) +!-------------------------------------------------- +! THIS FUNCTION HAS BEEN DESIGNED TO EVALUATE AN UPPER LIMIT +! FOR THE POLLUTANT DEPOSITION VELOCITY AS A FUNCTION OF THE +! SURFACE ROUGHNESS AND METEOROLOGICAL CONDITIONS. +! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) +! Modified by Darrell A. Winner (Feb. 1991) +! by Winfried Seidl (Aug. 1997) +!.....PROGRAM VARIABLES... +! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH +! ZR - REFERENCE HEIGHT +! Z0 - SURFACE ROUGHNESS HEIGHT +! SCPR23 - (Schmidt #/Prandtl #)**(2/3) Diffusion correction fact +! UBAR - ABSOLUTE VALUE OF SURFACE WIND SPEED +! DEPVEL - POLLUTANT DEPOSITION VELOCITY +! Vk - VON KARMAN CONSTANT +! USTAR - FRICTION VELOCITY U* +! POLINT - POLLUTANT INTEGRAL +! AER_RES - AERODYNAMIC RESISTANCE +!.....REFERENCES... +! MCRAE, G.J. ET AL. (1983) MATHEMATICAL MODELING OF PHOTOCHEMICAL +! AIR POLLUTION, ENVIRONMENTAL QUALITY LABORATORY REPORT 18, +! CALIFORNIA INSTITUTE OF TECHNOLOGY, PASADENA, CALIFORNIA. +!.....RESTRICTIONS... +! 1. THE MODEL EDDY DIFFUSIVITIES ARE BASED ON MONIN-OBUKHOV +! SIMILARITY THEORY AND SO ARE ONLY APPLICABLE IN THE +! SURFACE LAYER, A HEIGHT OF O(30M). +! 2. ALL INPUT UNITS MUST BE CONSISTENT +! 3. THE PHI FUNCTIONS USED TO CALCULATE THE FRICTION +! VELOCITY U* AND THE POLLUTANT INTEGRALS ARE BASED +! ON THE WORK OF BUSINGER ET AL.(1971). +! 4. THE MOMENTUM AND POLLUTANT DIFFUSIVITIES ARE NOT +! THE SAME FOR THE CASES L<0 AND L>0. +!-------------------------------------------------- + +! USE module_model_constants, only: karman + implicit none + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: numgas + REAL(KIND_PHYS), intent(in) :: ustar, z0, zr + REAL(KIND_PHYS), intent(out) :: vgpart, aer_res + REAL(KIND_PHYS), intent(inout) :: rmol +!-------------------------------------------------- +! .. Array Arguments .. +!-------------------------------------------------- + REAL(KIND_PHYS), intent(out) :: depv(numgas) +!-------------------------------------------------- +! .. Local Scalars .. +!-------------------------------------------------- + INTEGER :: l + REAL(KIND_PHYS) :: ao, ar, polint, vk +!-------------------------------------------------- +! .. Intrinsic Functions .. +!-------------------------------------------------- + INTRINSIC alog +!-------------------------------------------------- +! Set the von Karman constant +!-------------------------------------------------- + vk = karman + +!-------------------------------------------------- +! Calculate the diffusion correction factor +! SCPR23 is calculated as (Sc/Pr)**(2/3) using Sc= 1.15 and Pr= 1.0 +! DATA%SCPR23 = 1.10 +!-------------------------------------------------- +! DETERMINE THE STABILITY BASED ON THE CONDITIONS +! 1/L < 0 UNSTABLE +! 1/L = 0 NEUTRAL +! 1/L > 0 STABLE +!-------------------------------------------------- + + if(abs(rmol) < 1.E-6 ) rmol = 0. + + IF (rmol<0) THEN + ar = ((1.0-9.0*zr*rmol)**(0.25)+0.001)**2 + ao = ((1.0-9.0*z0*rmol)**(0.25)+0.001)**2 + polint = 0.74*(alog((ar-1.0)/(ar+1.0))-alog((ao-1.0)/(ao+1.0))) + ELSE IF (rmol==0.) THEN + polint = 0.74*alog(zr/z0) + ELSE + polint = 0.74*alog(zr/z0) + 4.7*rmol*(zr-z0) + END IF + +!-------------------------------------------------- +! CALCULATE THE Maximum DEPOSITION VELOCITY +!-------------------------------------------------- + DO l = 1, numgas + depv(l) = ustar*vk/(2.0*data%scpr23(l)+polint) + END DO + vgpart = ustar*vk/polint + aer_res = polint/(karman*max(ustar,1.0e-4)) + + END SUBROUTINE depvel + + ! NOTE: dep_init is now in rrfs_smoke_data + +end module dep_simple_mod diff --git a/smoke/dep_vertmx_mod.F90 b/smoke/dep_vertmx_mod.F90 new file mode 100755 index 000000000..5933af271 --- /dev/null +++ b/smoke/dep_vertmx_mod.F90 @@ -0,0 +1,209 @@ +MODULE dep_vertmx_mod + use rrfs_smoke_data + use machine , only : kind_phys + +CONTAINS + +!----------------------------------------------------------------------- + SUBROUTINE vertmx( data, dt, phi, kt_turb, dryrho, & + zsigma, zsigma_half, vd, kts, ktem1 ) +! !! purpose - calculate change in time of phi due to vertical mixing +! !! and dry deposition (for 1 species, 1 vertical column, 1 time step) +! !! Mariusz Pagowski, March 2001 +! !! conventions used: +! !! input is lower case +! !! output is upper case +! +! !! modifications by R Easter, May 2006 +! !! added dryrho so this routine conserves column mass burde +! !! when dry deposition velocity is zero +! !! changed "kte" to "ktem1" for consistency with the kte in WRF +! +! ARGUMENTS +! +! dt = time step (s) +! phi = initial/final (at input/output) species mixing ratios at "T" points +! kt_turb = turbulent exchange coefficients (m^2/s) at "W" points +! dryrho = dry air density (kg/m^3) at "T" points +! zsigma = heights (m) at "W" points +! zsigma_half = heights (m) at "T" points +! vd = dry deposition velocity (m/s) +! kts, ktem1 = vertical indices of bottom and top "T" points +! + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! .. Scalar Arguments .. + INTEGER, INTENT(IN) :: kts,ktem1 + REAL(KIND=KIND_PHYS), INTENT(IN) :: dt, vd +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: kt_turb, zsigma + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: dryrho, zsigma_half + REAL(KIND=KIND_PHYS), INTENT(INOUT), DIMENSION (kts:ktem1) :: phi +! .. +! .. Local Scalars .. + INTEGER :: k +! .. +! .. Local Arrays .. + REAL(KIND=KIND_PHYS), DIMENSION (kts+1:ktem1) :: a_coeff + REAL(KIND=KIND_PHYS), DIMENSION (kts:ktem1) :: b_coeff, lhs1, lhs2, lhs3, rhs +! .. +! .. External Subroutines .. +! EXTERNAL coeffs, rlhside, tridiag +! .. + CALL coeffs( data, kts, ktem1, dryrho, zsigma, zsigma_half, a_coeff, b_coeff ) + + CALL rlhside( data, kts, ktem1, kt_turb, dryrho, a_coeff, b_coeff, & + phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) + + CALL tridiag( data, kts, ktem1, lhs1, lhs2, lhs3, rhs ) + + DO k = kts,ktem1 + phi(k) = rhs(k) + END DO + + END SUBROUTINE vertmx + + +!----------------------------------------------------------------------- + SUBROUTINE rlhside( data, kts, ktem1, k_turb, dryrho, a_coeff, b_coeff, & + phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) + !! to calculate right and left hand sides in diffusion equation + !! for the tridiagonal solver + !! Mariusz Pagowski, March 2001 + !! conventions used: + !! input is lower case + !! output is upper case + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! .. Scalar Arguments .. + INTEGER, INTENT(IN) :: kts,ktem1 + REAL(KIND=KIND_PHYS), INTENT(IN) :: dt, vd +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: k_turb + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts+1:ktem1) :: a_coeff + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: b_coeff, dryrho + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: phi + REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts:ktem1) :: lhs1, lhs2, lhs3, rhs +! .. +! .. Local Scalars .. + !REAL(KIND_PHYS) :: a1, a2, alfa_explicit = .25, beta_implicit = .75 + REAL(KIND_PHYS) :: a1, a2, alfa_explicit = .0, beta_implicit = 1. + INTEGER :: i + +! .. + i = kts + a2 = a_coeff(i+1)*k_turb(i+1) + rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(vd*dryrho(i)+a2))*phi(i) + & + alfa_explicit*(a2*phi(i+1)) + lhs1(i) = 0. + lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(vd*dryrho(i)+a2) + lhs3(i) = -beta_implicit*a2 + + DO i = kts+1, ktem1-1 + a1 = a_coeff(i)*k_turb(i) + a2 = a_coeff(i+1)*k_turb(i+1) + + rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1+a2))*phi(i) + & + alfa_explicit*(a1*phi(i-1) + a2*phi(i+1)) + + lhs1(i) = -beta_implicit*a1 + lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1+a2) + lhs3(i) = -beta_implicit*a2 + END DO + + i = ktem1 + a1 = a_coeff(i)*k_turb(i) + rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1 ))*phi(i) + & + alfa_explicit*(a1*phi(i-1)) + lhs1(i) = -beta_implicit*a1 + lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1 ) + lhs3(i) = 0. + + END SUBROUTINE rlhside + + +!----------------------------------------------------------------------- + SUBROUTINE tridiag( data, kts, ktem1, a, b, c, f ) + !! to solve system of linear eqs on tridiagonal matrix n times n + !! after Peaceman and Rachford, 1955 + !! a,b,c,F - are vectors of order n + !! a,b,c - are coefficients on the LHS + !! F - is initially RHS on the output becomes a solution vector + !! Mariusz Pagowski, March 2001 + !! conventions used: + !! input is lower case + !! output is upper case + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! .. Scalar Arguments .. + INTEGER, INTENT(IN) :: kts,ktem1 +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: a, b, c + REAL(KIND=KIND_PHYS), INTENT(INOUT), DIMENSION (kts:ktem1) :: f +! .. +! .. Local Scalars .. + REAL(KIND_PHYS) :: p + INTEGER :: i +! .. +! .. Local Arrays .. + REAL(KIND=KIND_PHYS), DIMENSION (kts:ktem1) :: q +! .. + q(kts) = -c(kts)/b(kts) + f(kts) = f(kts)/b(kts) + + DO i = kts+1, ktem1 + p = 1./(b(i)+a(i)*q(i-1)) + q(i) = -c(i)*p + f(i) = (f(i)-a(i)*f(i-1))*p + END DO + + DO i = ktem1 - 1, kts, -1 + f(i) = f(i) + q(i)*f(i+1) + END DO + + END SUBROUTINE tridiag + + +!----------------------------------------------------------------------- + SUBROUTINE coeffs( data, kts, ktem1, dryrho, & + z_sigma, z_sigma_half, a_coeff, b_coeff ) +! !! to calculate coefficients in diffusion equation +! !! Mariusz Pagowski, March 2001 +! !! conventions used: +! !! input is lower case +! !! output is upper case +! .. Scalar Arguments .. + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + + INTEGER, INTENT(IN) :: kts,ktem1 +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: z_sigma + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: z_sigma_half, dryrho + REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts+1:ktem1) :: a_coeff + REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts:ktem1) :: b_coeff +! .. +! .. Local Scalars .. + INTEGER :: i + REAL(KIND=KIND_PHYS) :: dryrho_at_w +! .. + DO i = kts, ktem1 + b_coeff(i) = 1./(dryrho(i)*(z_sigma(i+1)-z_sigma(i))) + END DO + + DO i = kts+1, ktem1 + dryrho_at_w = 0.5*(dryrho(i)+dryrho(i-1)) + a_coeff(i) = dryrho_at_w/(z_sigma_half(i)-z_sigma_half(i-1)) + END DO + + END SUBROUTINE coeffs + +!----------------------------------------------------------------------- +END MODULE dep_vertmx_mod diff --git a/smoke/dep_wet_ls_mod.F90 b/smoke/dep_wet_ls_mod.F90 new file mode 100755 index 000000000..bfbe275f2 --- /dev/null +++ b/smoke/dep_wet_ls_mod.F90 @@ -0,0 +1,565 @@ +module dep_wet_ls_mod + use rrfs_smoke_data + use machine , only : kind_phys + use rrfs_smoke_config + use physcons, only : grav => con_g +! use chem_tracers_mod +! use chem_rc_mod +! use chem_tracers_mod +! use chem_const_mod, only : grav => grvity + + implicit none + + ! -- large scale wet deposition scavenging factors + + private + + public :: dep_wet_ls_init + public :: wetdep_ls + public :: WetRemovalGOCART + +contains + +! subroutine dep_wet_ls_init(config, rc) + subroutine dep_wet_ls_init(data) + implicit none + type(smoke_data), intent(inout) :: data + + ! -- I/O arguments +! type(chem_config_type), intent(in) :: config +! integer, intent(out) :: rc + + ! -- local variables + integer :: ios, n + + ! -- begin + !rc = CHEM_RC_SUCCESS + + ! -- set aerosol wet scavenging coefficients + if (associated(data%alpha)) then + deallocate(data%alpha, stat=ios) + !if (chem_rc_test((ios /= 0), msg="Failed to deallocate memory", & + ! file=__FILE__, line=__LINE__, rc=rc)) return + end if + + allocate(data%alpha(num_chem), stat=ios) + !if (chem_rc_test((ios /= 0), msg="Failed to allocate memory", & + ! file=__FILE__, line=__LINE__, rc=rc)) return + + data%alpha = 0. + + select case (wetdep_ls_opt) + case (WDLS_OPT_GSD) + + select case (chem_opt) + case (CHEM_OPT_GOCART) + data%alpha = 1.0 + end select + + case (WDLS_OPT_NGAC) + + select case (chem_opt) + case (CHEM_OPT_GOCART) + data%alpha(p_so2 ) = 0. + data%alpha(p_sulf ) = 1.5 + data%alpha(p_dms ) = 0. + data%alpha(p_msa ) = 0. + data%alpha(p_p25 ) = 1. + data%alpha(p_bc1 ) = 0.7 + data%alpha(p_bc2 ) = 0.7 + data%alpha(p_oc1 ) = 1. + data%alpha(p_oc2 ) = 1. + data%alpha(p_dust_1) = 1. + data%alpha(p_dust_2) = 1. + data%alpha(p_dust_3) = 1. + data%alpha(p_dust_4) = 1. + data%alpha(p_dust_5) = 1. + data%alpha(p_seas_1) = 1. + data%alpha(p_seas_2) = 1. + data%alpha(p_seas_3) = 1. + data%alpha(p_seas_4) = 1. + data%alpha(p_seas_5) = 1. + data%alpha(p_p10 ) = 1. + case default + ! -- NGAC large scale wet deposition only works with GOCART + end select + + case default + end select + + ! -- replace first default wet scavenging coefficients with input values if + ! available + if (any(wetdep_ls_alpha > 0._kind_phys)) then + n = min(size(data%alpha), size(wetdep_ls_alpha)) + data%alpha(1:n) = real(wetdep_ls_alpha(1:n)) + end if + + end subroutine dep_wet_ls_init + + + + subroutine wetdep_ls(data,dt,var,rain,moist,rho,var_rmv, & + num_moist,num_chem,p_qc,p_qi,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + + INTEGER, INTENT(IN ) :: num_chem,num_moist,p_qc, p_qi, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real(kind_phys), INTENT(IN ) :: dt + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: rho,dz8w,vvel + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem), & + INTENT(INOUT) :: var + REAL(kind_phys), DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: rain + REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & + INTENT(INOUT ) :: var_rmv + REAL(kind_phys), DIMENSION( its:ite , jts:jte ) :: var_sum + REAL(kind_phys), DIMENSION( its:ite , kts:kte, jts:jte ) :: var_rmvl + REAL(kind_phys), DIMENSION( its:ite , jts:jte ) :: frc,var_sum_clw,rain_clw + real(kind_phys) :: dvar,factor,rho_water + integer :: nv,i,j,k + + rho_water = 1000. + var_rmv (:,:,:)=0. + + do nv=1,num_chem +! +! simple LS removal +! + +! +! proportionality constant +! + frc(:,:)=0.1 + do i=its,ite + do j=jts,jte + var_sum_clw(i,j)=0. + var_sum(i,j)=0. + var_rmvl(i,:,j)=0. + rain_clw(i,j)=0. + if(rain(i,j).gt.1.e-6)then +! convert rain back to rate +! + rain_clw(i,j)=rain(i,j)/dt +! total cloud water +! + do k=1,kte + dvar=max(0.,(moist(i,k,j,p_qc)+moist(i,k,j,p_qi))) + var_sum_clw(i,j)=var_sum_clw(i,j)+dvar + enddo + endif + enddo + enddo +! +! get rid of it +! + do i=its,ite + do j=jts,jte + if(rain(i,j).gt.1.e-6 .and. var_sum_clw(i,j).gt.1.e-10 ) then + do k=kts,kte + if(var(i,k,j,nv).gt.1.e-08 .and. (moist(i,k,j,p_qc)+moist(i,k,j,p_qi)).gt.1.e-8)then + factor = max(0.,frc(i,j)*rho(i,k,j)*dz8w(i,k,j)*vvel(i,k,j)) + dvar=max(0.,data%alpha(nv)*factor/(1+factor)*var(i,k,j,nv)) + dvar=min(dvar,var(i,k,j,nv)) + var_rmvl(i,k,j)=dvar + if((var(i,k,j,nv)-dvar).lt.1.e-16)then + dvar=var(i,k,j,nv)-1.e-16 + var_rmvl(i,k,j)=dvar !lzhang + var(i,k,j,nv)=var(i,k,j,nv)-dvar + else + var(i,k,j,nv)=var(i,k,j,nv)-dvar + endif + !var_rmv(i,j,nv)=var_rmv(i,j,nv)+var_rmvl(i,k,j) + !!convert wetdeposition into ug/m2/s + var_rmv(i,j,nv)=var_rmv(i,j,nv)+(var_rmvl(i,k,j)*rho(i,k,j)*dz8w(i,k,j)/dt) !lzhang + endif + enddo + var_rmv(i,j,nv)=max(0.,var_rmv(i,j,nv)) + endif + enddo + enddo + enddo + + end subroutine wetdep_ls + +!------------------------------------------------------------------------- +! NASA/GSFC, Global Modeling and Assimilation Office, Code 900.3 ! +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: WetRemovalGOCART - Calculate aerosol wet removal due +! to large scale processes. +! +! !INTERFACE: +! + + subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & + num_chem, var_rmv, chem, ple, tmpu, & + rhoa, dqcond, precc, precl, & + ims, ime, jms, jme, kms, kme) +! ims, ime, jms, jme, kms, kme, rc ) + +! !USES: + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! !INPUT PARAMETERS: + integer, intent(in) :: i1, i2, j1, j2, k1, k2, n1, n2, num_chem, & + ims, ime, jms, jme, kms, kme + real(kind_phys), intent(in) :: cdt + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem),& + INTENT(INOUT) :: chem + REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & + INTENT(INOUT ) :: var_rmv !! tracer loss flux [kg m-2 s-1] + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme),& + INTENT(IN) :: ple, tmpu, rhoa, dqcond + real(kind_phys), dimension(ims:ime , jms:jme) , & + INTENT(IN) :: precc, precl ! cv, ls precip [mm day-1] + +! !OUTPUT PARAMETERS: +! integer, intent(out) :: rc ! Error return code: + ! 0 - all is well + ! 1 - + +! !DESCRIPTION: Calculates the updated species concentration due to wet +! removal. As written, intended to function for large +! scale (not convective) wet removal processes + +! +! !REVISION HISTORY: +! +! 08Jan2010 - Colarco, based on GOCART implementation, does not +! include any size dependent term +! +!EOP +!------------------------------------------------------------------------- + +! !Local Variables + character(len=*), parameter :: myname = 'WetRemovalGOCART' + integer :: i, j, k, n, nbins, LH, kk, ios,nv + real(kind_phys) :: pdog(i1:i2,k1:k2,j1:j2) ! air mass factor dp/g [kg m-2] + real(kind_phys) :: pls, pcv, pac ! ls, cv, tot precip [mm day-1] + real(kind_phys) :: qls(k1:k2), qcv(k1:k2) ! ls, cv portion dqcond [kg m-3 s-1] + real(kind_phys) :: qmx, qd, A ! temporary variables on moisture + real(kind_phys) :: F, B, BT ! temporary variables on cloud, freq. + real(kind_phys), allocatable :: fd(:,:) ! flux across layers [kg m-2] + real(kind_phys), allocatable :: DC(:) ! scavenge change in mass mixing ratio +! Rain parameters from Liu et al. + real(kind_phys), parameter :: B0_ls = 1.0e-4 + real(kind_phys), parameter :: F0_ls = 1.0 + real(kind_phys), parameter :: XL_ls = 5.0e-4 + real(kind_phys), parameter :: B0_cv = 1.5e-3 + real(kind_phys), parameter :: F0_cv = 0.3 + real(kind_phys), parameter :: XL_cv = 2.0e-3 +! Duration of rain: ls = model timestep, cv = 1800 s (<= cdt) + real(kind_phys) :: Td_ls + real(kind_phys) :: Td_cv + + +! Efficiency of dust wet removal (since dust is really not too hygroscopic) +! Applied only to in-cloud scavenging + real(kind_phys) :: effRemoval +! real(kind_phys),dimension(20) ::fwet +! tracer: p_so2=1 p_sulf=2 p_dms=3 p_msa=4 p_p25=5 p_bc1=6 p_bc2=7 p_oc1=8 +! p_oc2=9 p_dust_1=10 p_dust_2=11 p_dust_3=12 p_dust_4=13 p_dust_5=14 +! p_seas_1=15 p_seas_2=16 p_seas_3=17 p_seas_4=18 p_seas_5=19 p_p10 =20 +! data fwet /0.,1.5,0.,0.,1.,0.7,0.7,0.4,0.4,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1./ +! rc=0. + +! Initialize local variables +! -------------------------- +! rc = CHEM_RC_SUCCESS + + Td_ls = cdt + Td_cv = cdt + nbins = n2-n1+1 + var_rmv = 0.0 + +! Allocate the dynamic arrays + allocate(fd(k1:k2,nbins),stat=ios) +! if (chem_rc_test((ios .ne. 0), msg="Failed to allocate memory", & +! file=__FILE__, line=__LINE__, rc=rc)) return + allocate(dc(nbins),stat=ios) +! if (chem_rc_test((ios .ne. 0), msg="Failed to allocate memory", & +! file=__FILE__, line=__LINE__, rc=rc)) return + +! Accumulate the 3-dimensional arrays of rhoa and pdog + do j = j1, j2 + do i = i1, i2 + !pdog(i,k1:k2,j) = (ple(i,k1+1:k2+1,j)-ple(i,k1:k2,j)) / grav + pdog(i,k1:k2,j) = (ple(i,k1:k2,j)-ple(i,k1+1:k2+1,j)) / grav !lzhang + enddo + enddo + + do nv=1, num_chem +! Loop over spatial indices + do j = j1, j2 + do i = i1, i2 + +! Check for total precipitation amount +! Assume no precip in column if precl+precc = 0 + pac = precl(i,j) + precc(i,j) + if(pac .le. 0.) goto 100 + pls = precl(i,j) + pcv = precc(i,j) + +! Initialize the precipitation fields + qls(:) = 0. + qcv(:) = 0. + fd(:,:) = 0. + +! Find the highest model layer experiencing rainout. Assumes no +! scavenging if T < 258 K + !LH = 0 + LH = k2+1 !lzhang + !do k = k1, k2 + do k = k2, k1,-1 !lzhang + if(dqcond(i,k,j) .lt. 0. .and. tmpu(i,k,j) .gt. 258.) then + LH = k + goto 15 + endif + end do + 15 continue + !if(LH .lt. 1) goto 100 + if(LH .gt. k2) goto 100 !lzhang + +! convert dqcond from kg water/kg air/s to kg water/m3/s and reverse +! sign so that dqcond < 0. (positive precip) means qls and qcv > 0. + !do k = LH, k2 + do k = LH, k1, -1 !lzhang + qls(k) = -dqcond(i,k,j)*pls/pac*rhoa(i,k,j) + qcv(k) = -dqcond(i,k,j)*pcv/pac*rhoa(i,k,j) + end do + +! Loop over vertical to do the scavenging! + !do k = LH, k2 + do k = LH, k1, -1 !lzhang + +!----------------------------------------------------------------------------- +! (1) LARGE-SCALE RAINOUT: +! Tracer loss by rainout = TC0 * F * exp(-B*dt) +! where B = precipitation frequency, +! F = fraction of grid box covered by precipitating clouds. +! We assume that tracer scavenged by rain is falling down to the +! next level, where a fraction could be re-evaporated to gas phase +! if Qls is less then 0 in that level. +!----------------------------------------------------------------------------- + if (qls(k) .gt. 0.) then + F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(qls(k)*cdt/Td_ls)) + B = B0_ls/F0_ls +1./(F0_ls*XL_ls/qls(k)) + BT = B * Td_ls + if (BT.gt.10.) BT = 10. !< Avoid overflow > +! Adjust du level: + do n = 1, nbins + effRemoval = data%alpha(nv) + DC(n) = chem(i,k,j,nv) * F * effRemoval *(1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) chem(i,k,j,nv) = 1.0E-32 + end do +! Flux down: unit is kg m-2 +! Formulated in terms of production in the layer. In the revaporation step +! we consider possibly adding flux from above... + do n = 1, nbins + Fd(k,n) = DC(n)*pdog(i,k,j) + end do + + end if ! if Qls > 0 >>> + +!----------------------------------------------------------------------------- +! * (2) LARGE-SCALE WASHOUT: +! * Occurs when rain at this level is less than above. +!----------------------------------------------------------------------------- + !if(k .gt. LH .and. qls(k) .ge. 0.) then + if(k .lt. LH .and. qls(k) .ge. 0.) then !lzhang + !if(qls(k) .lt. qls(k-1)) then + if(qls(k) .lt. qls(k+1)) then !lzhang +! Find a maximum F overhead until the level where Qls<0. + Qmx = 0. + !do kk = k-1,LH,-1 + do kk = k+1,LH !lzhang + if (Qls(kk).gt.0.) then + Qmx = max(Qmx,Qls(kk)) + else + goto 333 + end if + end do + + 333 continue + F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(Qmx*cdt/Td_ls)) + if (F.lt.0.01) F = 0.01 +!----------------------------------------------------------------------------- +! The following is to convert Q(k) from kgH2O/m3/sec to mm/sec in order +! to use the Harvard formula. Convert back to mixing ratio by multiplying +! by rhoa. Multiply by pdog gives kg/m2/s of precip. Divide by density +! of water (=1000 kg/m3) gives m/s of precip and multiply by 1000 gives +! units of mm/s (omit the multiply and divide by 1000). +!----------------------------------------------------------------------------- + + Qd = Qmx /rhoa(i,k,j)*pdog(i,k,j) + if (Qd.ge.50.) then + B = 0. + else + B = Qd * 0.1 + end if + BT = B * cdt + if (BT.gt.10.) BT = 10. + +! Adjust du level: + do n = 1, nbins + DC(n) = chem(i,k,j,nv) * F * (1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) & + chem(i,k,j,nv) = 1.0E-32 + var_rmv(i,j,nv) = var_rmv(i,j,nv)+DC(n)*pdog(i,k,j)/cdt !ug/m2/s + end do + + end if + end if ! if ls washout >>> +#if 0 +!----------------------------------------------------------------------------- +! (3) CONVECTIVE RAINOUT: +! Tracer loss by rainout = dd0 * F * exp(-B*dt) +! where B = precipitation frequency, +! F = fraction of grid box covered by precipitating clouds. +!----------------------------------------------------------------------------- + + if (qcv(k) .gt. 0.) then + F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qcv(k)*cdt/Td_cv)) + B = B0_cv + BT = B * Td_cv + if (BT.gt.10.) BT = 10. !< Avoid overflow > + +! Adjust du level: + do n = 1, nbins + effRemoval = data%alpha(nv) + DC(n) = chem(i,k,j,nv) * F * effRemoval * (1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) chem(i,k,j,nv) = 1.0E-32 + end do + +!------ Flux down: unit is kg. Including both ls and cv. + do n = 1, nbins + Fd(k,n) = Fd(k,n) + DC(n)*pdog(i,k,j) + end do + + end if ! if Qcv > 0 >>> + +!----------------------------------------------------------------------------- +! (4) CONVECTIVE WASHOUT: +! Occurs when rain at this level is less than above. +!----------------------------------------------------------------------------- + + !if (k.gt.LH .and. Qcv(k).ge.0.) then + if (k.lt.LH .and. Qcv(k).ge.0.) then !lzhang + !if (Qcv(k).lt.Qcv(k-1)) then + if (Qcv(k).lt.Qcv(k+1)) then !lzhang +!----- Find a maximum F overhead until the level where Qls<0. + Qmx = 0. + !do kk = k-1, LH, -1 + do kk = k+1, LH !lzhang + if (Qcv(kk).gt.0.) then + Qmx = max(Qmx,Qcv(kk)) + else + goto 444 + end if + end do + + 444 continue + F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qmx*cdt/Td_cv)) + if (F.lt.0.01) F = 0.01 +!----------------------------------------------------------------------------- +! The following is to convert Q(k) from kgH2O/m3/sec to mm/sec in order +! to use the Harvard formula. Convert back to mixing ratio by multiplying +! by rhoa. Multiply by pdog gives kg/m2/s of precip. Divide by density +! of water (=1000 kg/m3) gives m/s of precip and multiply by 1000 gives +! units of mm/s (omit the multiply and divide by 1000). +!----------------------------------------------------------------------------- + + Qd = Qmx / rhoa(i,k,j)*pdog(i,k,j) + if (Qd.ge.50.) then + B = 0. + else + B = Qd * 0.1 + end if + BT = B * cdt + if (BT.gt.10.) BT = 10. + +! Adjust du level: + do n = 1, nbins + DC(n) = chem(i,k,j,nv) * F * (1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) & + chem(i,k,j,nv) = 1.0E-32 + var_rmv(i,j,nv) = var_rmv(i,j,nv)+DC(n)*pdog(i,k,j)/cdt !ug/m2/s + end do + + end if + end if ! if cv washout >>> +#endif +!----------------------------------------------------------------------------- +! (5) RE-EVAPORATION. Assume that SO2 is re-evaporated as SO4 since it +! has been oxidized by H2O2 at the level above. +!----------------------------------------------------------------------------- +! Add in the flux from above, which will be subtracted if reevaporation occurs + !if(k .gt. LH) then + if(k .lt. LH) then !lzhang + do n = 1, nbins + !Fd(k,n) = Fd(k,n) + Fd(k-1,n) + Fd(k,n) = Fd(k,n) + Fd(k+1,n) !lzhang + end do + +! Is there evaporation in the currect layer? + if (-dqcond(i,k,j) .lt. 0.) then +! Fraction evaporated = H2O(k)evap / H2O(next condensation level). + !if (-dqcond(i,k-1,j) .gt. 0.) then + if (-dqcond(i,k+1,j) .gt. 0.) then !lzhang + + A = abs( dqcond(i,k,j) * pdog(i,k,j) & + !/ ( dqcond(i,k-1,j) * pdog(i,k-1,j)) ) + / ( dqcond(i,k+1,j) * pdog(i,k+1,j)) ) !lzhang + if (A .gt. 1.) A = 1. + +! Adjust tracer in the level + do n = 1, nbins + !DC(n) = Fd(k-1,n) / pdog(i,k,j) * A + DC(n) = Fd(k+1,n) / pdog(i,k,j) * A !lzhang + chem(i,k,j,nv) = chem(i,k,j,nv) + DC(n) + chem(i,k,j,nv) = max(chem(i,k,j,nv),1.e-32) +! Adjust the flux out of the bottom of the layer + Fd(k,n) = Fd(k,n) - DC(n)*pdog(i,k,j) + end do + + endif + endif ! if -moistq < 0 + endif + end do ! k + + do n = 1, nbins + !var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k2,n)/cdt !lzhang + var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k1,n)/cdt ! ug/m2/s + end do + + 100 continue + end do ! i + end do ! j + end do !nv for num_chem + + deallocate(fd,DC,stat=ios) +! if (chem_rc_test((ios .ne. 0), msg="Failed to deallocate memory", & +! file=__FILE__, line=__LINE__, rc=rc)) return + + end subroutine WetRemovalGOCART + +end module dep_wet_ls_mod diff --git a/smoke/dust_data_mod.F90 b/smoke/dust_data_mod.F90 new file mode 100755 index 000000000..33767701b --- /dev/null +++ b/smoke/dust_data_mod.F90 @@ -0,0 +1,108 @@ +module dust_data_mod + + use rrfs_smoke_data + use machine , only : kind_phys + use rrfs_smoke_config, only : p_dust_1, p_dust_2, p_dust_3, p_dust_4, p_dust_5, & + p_edust1, p_edust2, p_edust3, p_edust4, p_edust5 + + + implicit none + + integer, parameter :: ndust = 5 + integer, parameter :: ndcls = 3 + integer, parameter :: ndsrc = 1 + integer, parameter :: maxstypes = 100 + integer, parameter :: nsalt = 9 + + real(kind_phys), parameter :: dyn_visc = 1.5E-5 + + ! -- dust parameters + ! never used: integer, dimension(ndust), parameter :: ipoint = (/ 3, 2, 2, 2, 2 /) + real(kind_phys), dimension(ndust), parameter :: den_dust = (/ 2500., 2650., 2650., 2650., 2650. /) + real(kind_phys), dimension(ndust), parameter :: reff_dust = (/ 0.73D-6, 1.4D-6, 2.4D-6, 4.5D-6, 8.0D-6 /) + real(kind_phys), dimension(ndust), parameter :: frac_s = (/ 0.1, 0.25, 0.25, 0.25, 0.25 /) + real(kind_phys), dimension(ndust), parameter :: lo_dust = (/ 0.1D-6, 1.0D-6, 1.8D-6, 3.0D-6, 6.0D-6 /) + real(kind_phys), dimension(ndust), parameter :: up_dust = (/ 1.0D-6, 1.8D-6, 3.0D-6, 6.0D-6,10.0D-6 /) + ! never used: real(kind_phys), dimension(ndust, 12) :: ch_dust = 0.8e-09_kind_phys + + ! -- default dust parameters + ! -- AFWA & GOCART + ! -----------+----------+-----------+ + ! Parameter | FIM-Chem | HRRR-Chem | + ! -----------+----------+-----------+ + ! alpha | 1.0 | 0.5 | + ! gamma | 1.6 | 1.0 | + ! -----------+----------+-----------+ + ! Never used: + ! real(kind_phys), parameter :: afwa_alpha = 0.2 + ! real(kind_phys), parameter :: afwa_gamma = 1.3 + ! real(kind_phys), parameter :: gocart_alpha = 0.3 + ! real(kind_phys), parameter :: gocart_gamma = 1.3 + ! -- FENGSHA + ! Never used: + ! real(kind_phys), parameter :: fengsha_alpha = 0.3 + ! real(kind_phys), parameter :: fengsha_gamma = 1.3 + ! -- FENGSHA threshold velocities based on Dale A. Gillette's data + integer, parameter :: fengsha_maxstypes = 13 +! real(kind_phys), dimension(fengsha_maxstypes) :: dust_uthres = & +! (/ 0.065, & ! Sand - 1 +! 0.20, & ! Loamy Sand - 2 +! 0.52, & ! Sandy Loam - 3 +! 0.50, & ! Silt Loam - 4 +! 0.50, & ! Silt - 5 +! 0.60, & ! Loam - 6 +! 0.73, & ! Sandy Clay Loam - 7 +! 0.73, & ! Silty Clay Loam - 8 +! 0.80, & ! Clay Loam - 9 +! 0.95, & ! Sandy Clay - 10 +! 0.95, & ! Silty Clay - 11 +! 1.00, & ! Clay - 12 +! 9.999 /) ! Other - 13 +! dust_uthres = 0.065, 0.18, 0.27, 0.30, 0.35, 0.38, 0.35, 0.41, 0.41, +! 0.45,0.50,0.45,9999.0 + real(kind_phys), dimension(fengsha_maxstypes), parameter :: dust_uthres = & + (/ 0.065, & ! Sand - 1 + 0.18, & ! Loamy Sand - 2 + 0.27, & ! Sandy Loam - 3 + 0.30, & ! Silt Loam - 4 + 0.35, & ! Silt - 5 + 0.38, & ! Loam - 6 + 0.35, & ! Sandy Clay Loam - 7 + 0.41, & ! Silty Clay Loam - 8 + 0.41, & ! Clay Loam - 9 + 0.45, & ! Sandy Clay - 10 + 0.50, & ! Silty Clay - 11 + 0.45, & ! Clay - 12 + 9999.0 /) ! Other - 13 + ! -- FENGSHA uses precalculated drag partition from ASCAT. See: Prigent et al. (2012,2015) + integer, parameter :: dust_calcdrag = 1 + + real(kind_phys), parameter :: dust_alpha = 2.2 + real(kind_phys), parameter :: dust_gamma = 1.0 + + + ! -- sea salt parameters + integer, dimension(nsalt), parameter :: spoint = (/ 1, 2, 2, 2, 2, 2, 3, 3, 3 /) ! 1 Clay, 2 Silt, 3 Sand + real(kind_phys), dimension(nsalt), parameter :: reff_salt = & + (/ 0.71D-6, 1.37D-6, 2.63D-6, 5.00D-6, 9.50D-6, 18.1D-6, 34.5D-6, 65.5D-6, 125.D-6 /) + real(kind_phys), dimension(nsalt), parameter :: den_salt = & + (/ 2500., 2650., 2650., 2650., 2650., 2650., 2650., 2650., 2650. /) + real(kind_phys), dimension(nsalt), parameter :: frac_salt = & + (/ 1., 0.2, 0.2, 0.2, 0.2, 0.2, 0.333, 0.333, 0.333 /) + + + ! -- soil vagatation parameters + integer, parameter :: max_soiltyp = 30 + real(kind_phys), dimension(max_soiltyp), parameter :: & + maxsmc = (/ 0.421, 0.464, 0.468, 0.434, 0.406, 0.465, & + 0.404, 0.439, 0.421, 0.000, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 /) + + ! -- other soil parameters + ! never used: real(kind_phys), dimension(maxstypes) :: porosity + + public + +end module dust_data_mod diff --git a/smoke/dust_fengsha_mod.F90 b/smoke/dust_fengsha_mod.F90 new file mode 100755 index 000000000..c43719386 --- /dev/null +++ b/smoke/dust_fengsha_mod.F90 @@ -0,0 +1,598 @@ +module dust_fengsha_mod +! +! This module developed by Barry Baker (NOAA ARL) +! For serious questions contact barry.baker@noaa.gov +! +! 07/16/2019 - Adapted for NUOPC/GOCART, R. Montuoro +! 02/01/2020 - Adapted for FV3/CCPP, Haiqin Li + + use rrfs_smoke_data + use machine , only : kind_phys + use dust_data_mod + + implicit none + + private + + public :: gocart_dust_fengsha_driver + +contains + + subroutine gocart_dust_fengsha_driver(data, dt, & + chem,rho_phy,smois,p8w,ssm, & + isltyp,vegfra,snowh,xland,area,g,emis_dust, & + ust,znt,clay,sand,rdrag,uthr, & + num_emis_dust,num_moist,num_chem,num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + num_emis_dust,num_moist,num_chem,num_soil_layers + INTEGER,DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: isltyp + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT) :: chem + REAL(kind_phys), DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL, INTENT(INOUT) :: emis_dust + REAL(kind_phys), DIMENSION( ims:ime, num_soil_layers, jms:jme ), INTENT(IN) :: smois + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ssm + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: vegfra, & + snowh, & + xland, & + area, & + ust, & + znt, & + clay, & + sand, & + rdrag, & + uthr + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: & + p8w, & + rho_phy + REAL(kind_phys), INTENT(IN) :: dt,g + + ! Local variables + + integer :: nmx,smx,i,j,k,imx,jmx,lmx + integer,dimension (1,1) :: ilwi + real(kind_phys), DIMENSION (1,1) :: erodtot + REAL(kind_phys), DIMENSION (1,1) :: gravsm + REAL(kind_phys), DIMENSION (1,1) :: drylimit + real(kind_phys), DIMENSION (5) :: tc,bems + real(kind_phys), dimension (1,1) :: airden,airmas,ustar + real(kind_phys), dimension (1) :: dxy + real(kind_phys), dimension (3) :: massfrac + real(kind_phys) :: conver,converi + real(kind_phys) :: R + + ! threshold values + conver=1.e-9 + converi=1.e9 + + ! Number of dust bins + + imx=1 + jmx=1 + lmx=1 + nmx=ndust + smx=nsalt + + k=kts + do j=jts,jte + do i=its,ite + + ! Don't do dust over water!!! + + ilwi(1,1)=0 + if(xland(i,j).lt.1.5)then + ilwi(1,1)=1 + + ! Total concentration at lowest model level. This is still hardcoded for 5 bins. + + ! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then + ! tc(:)=1.e-16*conver + ! else + tc(1)=chem(i,kts,j,p_dust_1)*conver + tc(2)=chem(i,kts,j,p_dust_2)*conver + tc(3)=chem(i,kts,j,p_dust_3)*conver + tc(4)=chem(i,kts,j,p_dust_4)*conver + tc(5)=chem(i,kts,j,p_dust_5)*conver + ! endif + + ! Air mass and density at lowest model level. + + airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g + airden(1,1)=rho_phy(i,kts,j) + ustar(1,1)=ust(i,j) + dxy(1)=area(i,j) + + ! Mass fractions of clay, silt, and sand. + massfrac(1)=clay(i,j) + massfrac(2)=1-(clay(i,j)+sand(i,j)) + massfrac(3)=sand(i,j) + + + ! Total erodibility. + + erodtot(1,1) = ssm(i,j) ! SUM(erod(i,j,:)) + + ! Don't allow roughness lengths greater than 20 cm to be lofted. + ! This kludge accounts for land use types like urban areas and + ! forests which would otherwise show up as high dust emitters. + ! This is a placeholder for a more widely accepted kludge + ! factor in the literature, which reduces lofting for rough areas. + ! Forthcoming... + + IF (znt(i,j) .gt. 0.2) then + ilwi(1,1)=0 + endif + + ! limit where there is lots of vegetation + if (vegfra(i,j) .gt. .17) then + ilwi(1,1) = 0 + endif + + ! limit where there is snow on the ground + if (snowh(i,j) .gt. 0) then + ilwi(1,1) = 0 + endif + + ! Do not allow areas with bedrock, lava, or land-ice to loft + + IF (isltyp(i,j) .eq. 15 .or. isltyp(i,j) .eq. 16. .or. & + isltyp(i,j) .eq. 18) then + ilwi(1,1)=0 + ENDIF + IF (isltyp(i,j) .eq. 0)then + ilwi(1,1)=0 + endif + if(ilwi(1,1) == 0 ) cycle + + ! Calculate gravimetric soil moisture and drylimit. + gravsm(1,1)=100.*smois(i,1,j)/((1.-maxsmc(isltyp(i,j)))*(2.65*(1.-clay(i,j))+2.50*clay(i,j))) + drylimit(1,1)=14.0*clay(i,j)*clay(i,j)+17.0*clay(i,j) + + ! get drag partition + ! FENGSHA uses the drag partition correction of MacKinnon et al 2004 + ! doi:10.1016/j.geomorph.2004.03.009 + if (dust_calcdrag .ne. 1) then + call fengsha_drag(data,znt(i,j),R) + else + ! use the precalculated version derived from ASCAT; Prigent et al. (2012,2015) + ! doi:10.1109/TGRS.2014.2338913 & doi:10.5194/amt-5-2703-2012 + ! pick only valid values + if (rdrag(i,j) > 0.) then + R = real(rdrag(i,j), kind=kind_phys) + else + cycle + endif + endif + + ! Call dust emission routine. + call source_dust(data, imx, jmx, lmx, nmx, smx, dt, tc, ustar, massfrac, & + erodtot, dxy, gravsm, airden, airmas, & + bems, g, drylimit, dust_alpha, dust_gamma, R, uthr(i,j)) + + ! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then + ! dustin(i,j,1:5)=tc(1:5)*converi + ! else + chem(i,kts,j,p_dust_1)=tc(1)*converi + chem(i,kts,j,p_dust_2)=tc(2)*converi + chem(i,kts,j,p_dust_3)=tc(3)*converi + chem(i,kts,j,p_dust_4)=tc(4)*converi + chem(i,kts,j,p_dust_5)=tc(5)*converi + ! endif + + ! chem(i,kts,j,p_dust_1)=tc(1)*converi + ! chem(i,kts,j,p_dust_2)=tc(2)*converi + ! chem(i,kts,j,p_dust_3)=tc(3)*converi + ! chem(i,kts,j,p_dust_4)=tc(4)*converi + ! chem(i,kts,j,p_dust_5)=tc(5)*converi + + ! For output diagnostics + + emis_dust(i,1,j,p_edust1)=bems(1) + emis_dust(i,1,j,p_edust2)=bems(2) + emis_dust(i,1,j,p_edust3)=bems(3) + emis_dust(i,1,j,p_edust4)=bems(4) + emis_dust(i,1,j,p_edust5)=bems(5) + endif + enddo + enddo + ! + + end subroutine gocart_dust_fengsha_driver + + + SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & + erod, dxy, gravsm, airden, airmas, bems, g0, drylimit, alpha, & + gamma, R, uthres) + + ! **************************************************************************** + ! * Evaluate the source of each dust particles size bin by soil emission + ! * + ! * Input: + ! * EROD Fraction of erodible grid cell (-) + ! * GRAVSM Gravimetric soil moisture (g/g) + ! * DRYLIMIT Upper GRAVSM limit for air-dry soil (g/g) + ! * ALPHA Constant to fudge the total emission of dust (1/m) + ! * GAMMA Tuning constant for erodibility (-) + ! * DXY Surface of each grid cell (m2) + ! * AIRMAS Mass of air for each grid box (kg) + ! * AIRDEN Density of air for each grid box (kg/m3) + ! * USTAR Friction velocity (m/s) + ! * DT1 Time step (s) + ! * NMX Number of dust bins (-) + ! * SMX Number of saltation bins (-) + ! * IMX Number of I points (-) + ! * JMX Number of J points (-) + ! * LMX Number of L points (-) + ! * R Drag Partition (-) + ! * UTHRES FENGSHA Dry Threshold Velocities (m/s) + ! * + ! * Data: + ! * MASSFRAC Fraction of mass in each of 3 soil classes (-) + ! * SPOINT Pointer to 3 soil classes (-) + ! * DEN_DUST Dust density (kg/m3) + ! * DEN_SALT Saltation particle density (kg/m3) + ! * REFF_SALT Reference saltation particle diameter (m) + ! * REFF_DUST Reference dust particle diameter (m) + ! * LO_DUST Lower diameter limits for dust bins (m) + ! * UP_DUST Upper diameter limits for dust bins (m) + ! * FRAC_SALT Soil class mass fraction for saltation bins (-) + ! * + ! * Parameters: + ! * CMB Constant of proportionality (-) + ! * MMD_DUST Mass median diameter of dust (m) + ! * GSD_DUST Geometric standard deviation of dust (-) + ! * LAMBDA Side crack propagation length (m) + ! * CV Normalization constant (-) + ! * G0 Gravitational acceleration (m/s2) + ! * G Gravitational acceleration in cgs (cm/s2) + ! * + ! * Working: + ! * U_TS0 "Dry" threshold friction velocity (m/s) + ! * U_TS Moisture-adjusted threshold friction velocity (m/s) + ! * RHOA Density of air in cgs (g/cm3) + ! * DEN Dust density in cgs (g/cm3) + ! * DIAM Dust diameter in cgs (cm) + ! * DMASS Saltation mass distribution (-) + ! * DSURFACE Saltation surface area per unit mass (m2/kg) + ! * DS_REL Saltation surface area distribution (-) + ! * SALT Saltation flux (kg/m/s) + ! * DLNDP Dust bin width (-) + ! * EMIT Total vertical mass flux (kg/m2/s) + ! * EMIT_VOL Total vertical volume flux (m/s) + ! * DSRC Mass of emitted dust (kg/timestep/cell) + ! * + ! * Output: + ! * TC Total concentration of dust (kg/kg/timestep/cell) + ! * BEMS Source of each dust type (kg/timestep/cell) + ! * + ! **************************************************************************** + implicit none + type(smoke_data), intent(inout) :: data + + INTEGER, INTENT(IN) :: imx,jmx,lmx,nmx,smx + REAL(kind_phys), INTENT(IN) :: dt1 + REAL(kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) + REAL(kind_phys), INTENT(IN) :: ustar(imx,jmx) + REAL(kind_phys), INTENT(IN) :: massfrac(3) + REAL(kind_phys), INTENT(IN) :: erod(imx,jmx) + REAL(kind_phys), INTENT(IN) :: dxy(jmx) + REAL(kind_phys), INTENT(IN) :: gravsm(imx,jmx) + REAL(kind_phys), INTENT(IN) :: airden(imx,jmx,lmx) + REAL(kind_phys), INTENT(IN) :: airmas(imx,jmx,lmx) + REAL(kind_phys), INTENT(OUT) :: bems(imx,jmx,nmx) + REAL(kind_phys), INTENT(IN) :: g0 + REAL(kind_phys), INTENT(IN) :: drylimit(imx,jmx) + !! Sandblasting mass efficiency, aka "fudge factor" (based on Tegen et al, + !! 2006 and Hemold et al, 2007) + ! + ! REAL, PARAMETER :: alpha=1.8E-8 ! (m^-1) + REAL(kind_phys), INTENT(IN) :: alpha + ! Experimental optional exponential tuning constant for erodibility. + ! 0 < gamma < 1 -> more relative impact by low erodibility regions. + REAL(kind_phys), INTENT(IN) :: gamma + REAL(kind_phys), INTENT(IN) :: R + REAL(kind_phys), INTENT(IN) :: uthres + + REAL(kind_phys) :: den(smx), diam(smx) + REAL(kind_phys) :: dvol(nmx), distr_dust(nmx), dlndp(nmx) + REAL(kind_phys) :: dsurface(smx), ds_rel(smx) + REAL(kind_phys) :: u_ts0, u_ts, dsrc, dmass, dvol_tot + REAL(kind_phys) :: salt,emit, emit_vol, stotal + REAL(kind_phys) :: rhoa, g + INTEGER :: i, j, n + + ! Sandblasting mass efficiency, beta. + ! Beta maxes out for clay fractions above 0.2 = betamax. + + REAL(kind_phys), PARAMETER :: betamax=5.25E-4 + REAL(kind_phys) :: beta + integer :: styp + + ! Constant of proportionality from Marticorena et al, 1997 (unitless) + ! Arguably more ~consistent~ fudge than alpha, which has many walnuts + ! sprinkled throughout the literature. - GC + + REAL(kind_phys), PARAMETER :: cmb=1.0 + ! REAL, PARAMETER :: cmb=2.61 ! from White,1979 + + ! Parameters used in Kok distribution function. Advise not to play with + ! these without the expressed written consent of someone who knows what + ! they're doing. - GC + + REAL(kind_phys), PARAMETER :: mmd_dust=3.4D-6 ! median mass diameter (m) + REAL(kind_phys), PARAMETER :: gsd_dust=3.0 ! geom. std deviation + REAL(kind_phys), PARAMETER :: lambda=12.0D-6 ! crack propagation length (m) + REAL(kind_phys), PARAMETER :: cv=12.62D-6 ! normalization constant + + ! Calculate saltation surface area distribution from sand, silt, and clay + ! mass fractions and saltation bin fraction. This will later become a + ! modifier to the total saltation flux. The reasoning here is that the + ! size and availability of saltators affects saltation efficiency. Based + ! on Eqn. (32) in Marticorena & Bergametti, 1995 (hereon, MB95). + + DO n=1,smx + dmass=massfrac(spoint(n))*frac_salt(n) + dsurface(n)=0.75*dmass/(den_salt(n)*reff_salt(n)) + ENDDO + + ! The following equation yields relative surface area fraction. It will only + ! work if you are representing the "full range" of all three soil classes. + ! For this reason alone, we have incorporated particle sizes that encompass + ! the clay class, to account for the its relative area over the basal + ! surface, even though these smaller bins would be unlikely to play any large + ! role in the actual saltation process. - GC + + stotal=SUM(dsurface(:)) + DO n=1,smx + ds_rel(n)=dsurface(n)/stotal + ENDDO + + ! Calculate total dust emission due to saltation of sand sized particles. + ! Begin by calculating DRY threshold friction velocity (u_ts0). Next adjust + ! u_ts0 for moisture to get threshold friction velocity (u_ts). Then + ! calculate saltation flux (salt) where ustar has exceeded u_ts. Finally, + ! calculate total dust emission (tot_emit), taking into account erodibility. + + ! Set DRY threshold friction velocity to input value + u_ts0 = uthres + + g = g0*1.0E2 + emit=0.0 + + DO n = 1, smx + den(n) = den_salt(n)*1.0D-3 ! (g cm^-3) + diam(n) = 2.0*reff_salt(n)*1.0D2 ! (cm) + DO i = 1,imx + DO j = 1,jmx + rhoa = airden(i,j,1)*1.0D-3 ! (g cm^-3) + + ! FENGSHA uses the 13 category soil type from the USDA + ! call calc_fengsha_styp(massfrac(1),massfrac(3),massfrac(2),styp) + ! Fengsha uses threshold velocities based on dale gilletes data + ! call fengsha_utst(styp,uthres,u_ts0) + + ! Friction velocity threshold correction function based on physical + ! properties related to moisture tension. Soil moisture greater than + ! dry limit serves to increase threshold friction velocity (making + ! it more difficult to loft dust). When soil moisture has not reached + ! dry limit, treat as dry + + IF (gravsm(i,j) > drylimit(i,j)) THEN + u_ts = MAX(0.0D+0,u_ts0*(sqrt(1.0+1.21*(gravsm(i,j)-drylimit(i,j))**0.68)) / R) + ELSE + u_ts = u_ts0 / R + END IF + + ! Calculate total vertical mass flux (note beta has units of m^-1) + ! Beta acts to tone down dust in areas with so few dust-sized particles that the + ! lofting efficiency decreases. Otherwise, super sandy zones would be huge dust + ! producers, which is generally not the case. Equation derived from wind-tunnel + ! experiments (see MB95). + + beta=10**(13.6*massfrac(1)-6.0) ! (unitless) + if (massfrac(1) <= 0.2) then + beta=10**(13.4*massfrac(1)-6.0) + else + beta = 2.E-4 + endif + + !--------------------------------------------------------------------- + ! formula of Draxler & Gillette (2001) Atmos. Environ. + ! F = K A (r/g) U* ( U*^2 - Ut*^2 ) + ! + ! where: + ! F = vertical emission flux [g/m**2-s] + ! K = constant 2.0E-04 [1/m] + ! A = 0~3.5 mean = 2.8 (fudge factor) + ! U* = friction velocity [m/s] + ! Ut* = threshold friction velocity [m/s] + ! + !-------------------------------------------------------------------- + + IF (ustar(i,j) .gt. u_ts) then + call fengsha_hflux(data,ustar(i,j),u_ts,beta, salt) + salt = alpha * cmb * ds_rel(n) * airden(i,j,1) / g0 * salt * (erod(i,j)**gamma) * beta + else + salt = 0. + endif + ! EROD is taken into account above + emit = emit + salt + END DO + END DO + END DO + + ! Now that we have the total dust emission, distribute into dust bins using + ! lognormal distribution (Dr. Jasper Kok, in press), and + ! calculate total mass emitted over the grid box over the timestep. + ! + ! In calculating the Kok distribution, we assume upper and lower limits to each bin. + ! For reff_dust=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) (default), + ! lower limits were ASSUMED at lo_dust=(/0.1D-6,1.0D-6,1.8D-6,3.0D-6,6.0D-6/) + ! upper limits were ASSUMED at up_dust=(/1.0D-6,1.8D-6,3.0D-6,6.0D-6,10.0D-6/) + ! These may be changed within module_data_gocart_dust.F, but make sure it is + ! consistent with reff_dust values. These values were taken from the original + ! GOCART bin configuration. We use them here to calculate dust bin width, dlndp. + ! dVol is the volume distribution. You know...if you were wondering. GC + + dvol_tot=0. + DO n=1,nmx + dlndp(n)=LOG(up_dust(n)/lo_dust(n)) + dvol(n)=(2.0*reff_dust(n)/cv)*(1.+ERF(LOG(2.0*reff_dust(n)/mmd_dust)/(SQRT(2.)*LOG(gsd_dust))))*& + EXP(-(2.0*reff_dust(n)/lambda)**3.0)*dlndp(n) + dvol_tot=dvol_tot+dvol(n) + ! Convert mass flux to volume flux + !emit_vol=emit/den_dust(n) ! (m s^-1) + END DO + DO n=1,nmx + distr_dust(n)=dvol(n)/dvol_tot + !print *,"distr_dust(",n,")=",distr_dust(n) + END DO + + ! Now distribute total vertical emission into dust bins and update concentration. + + DO n=1,nmx + DO i=1,imx + DO j=1,jmx + ! Calculate total mass emitted + dsrc = emit*distr_dust(n)*dxy(j)*dt1 ! (kg) + IF (dsrc < 0.0) dsrc = 0.0 + + ! Update dust mixing ratio at first model level. + tc(i,j,1,n) = tc(i,j,1,n) + dsrc / airmas(i,j,1) ! (kg/kg) + ! bems(i,j,n) = dsrc ! diagnostic + !bems(i,j,n) = 1000.*dsrc/(dxy(j)*dt1) ! diagnostic (g/m2/s) + bems(i,j,n) = 1.e+9*dsrc/(dxy(j)*dt1) ! diagnostic (ug/m2/s) !lzhang + END DO + END DO + END DO + + END SUBROUTINE source_dust + + subroutine fengsha_utst(data,styp,uth, ut) + implicit none + type(smoke_data), intent(inout) :: data + + integer, intent(in) :: styp + real(kind_phys), dimension(fengsha_maxstypes), intent(in) :: uth + real(kind_phys), intent(out) :: ut + ut = uth(styp) +! real (kind_phys) :: uth(13) = & +! (/ 0.08, & ! Sand - 1 +! 0.20, & ! Loamy Sand - 2 +! 0.30, & ! Sandy Loam - 3 +! 0.30, & ! Silt Loam - 4 +! 0.35, & ! Silt - 5 +! 0.60, & ! Loam - 6 +! 0.30, & ! Sandy Clay Loam - 7 +! 0.35, & ! Silty Clay Loam - 8 +! 0.45, & ! Clay Loam - 9 +! 0.45, & ! Sandy Clay - 10 +! 0.45, & ! Silty Clay - 11 +! 0.60, & ! Clay - 12 +! 9.999 /) ! Other - 13 + return + end subroutine fengsha_utst + + subroutine calc_fengsha_styp(data, clay, sand, silt, type) + implicit none + type(smoke_data), intent(inout) :: data + + !--------------------------------------------------------------- + ! Function: calculate soil type based on USDA definition. + ! Source: USDA soil texture calculator + ! + ! Defintion of soil types: + ! + ! + ! NOAH 1 2 3 4 5 6 7 8 9 10 11 12 + ! PX 1 2 3 4 - 5 6 7 8 9 10 11 + ! Soil "Sand" "Loamy Sand" "Sandy Loam" "Silt Loam" "Silt" "Loam" "Sandy Clay Loam" "Silt Clay Loam" "Clay Loam" "Sandy Clay" "Silty Clay" "Clay" + !--------------------------------------------------------------- + REAL(kind_phys), intent(in) :: clay, sand, silt + integer, intent(out) :: type + real(kind_phys) :: cly, snd, slt + + type = 0 + + snd = sand * 100. + cly = clay * 100. + slt = silt * 100. + if (slt+1.5*cly .lt. 15) type = 1 ! snd + if (slt+1.5*cly .ge. 15 .and.slt+1.5*cly .lt. 30) type = 2 ! loamy snd + if (cly .ge. 7 .and. cly .lt. 20 .and. snd .gt. 52 .and. slt+2*cly .ge. 30) type = 3 ! sndy loam (cond 1) + if (cly .lt. 7 .and. slt .lt. 50 .and. slt+2*cly .ge. 30) type = 3 ! sndy loam (cond 2) + if (slt .ge. 50 .and. cly .ge. 12 .and.cly .lt. 27 ) type = 4 ! slt loam (cond 1) + if (slt .ge. 50 .and. slt .lt. 80 .and.cly .lt. 12) type = 4 ! slt loam (cond 2) + if (slt .ge. 80 .and. cly .lt. 12) type = 5 ! slt + if (cly .ge. 7 .and. cly .lt. 27 .and.slt .ge. 28 .and. slt .lt. 50 .and.snd .le. 52) type = 6 ! loam + if (cly .ge. 20 .and. cly .lt. 35 .and.slt .lt. 28 .and. snd .gt. 45) type = 7 ! sndy cly loam + if (cly .ge. 27 .and. cly .lt. 40 .and.snd .lt. 20) type = 8 ! slt cly loam + if (cly .ge. 27 .and. cly .lt. 40 .and.snd .ge. 20 .and. snd .le. 45) type = 9 ! cly loam + if (cly .ge. 35 .and. snd .gt. 45) type = 10 ! sndy cly + if (cly .ge. 40 .and. slt .ge. 40) type = 11 ! slty cly + if (cly .ge. 40 .and. snd .le. 45 .and.slt .lt. 40) type = 12 ! clay + return + end subroutine calc_fengsha_styp + + subroutine fengsha_drag(data,z0,R) + implicit none + type(smoke_data), intent(inout) :: data + + real(kind_phys), intent(in) :: z0 + real(kind_phys), intent(out) :: R + real(kind_phys), parameter :: z0s = 1.0e-04 !Surface roughness for ideal bare surface [m] + ! ------------------------------------------------------------------------ + ! Function: Calculates the MacKinnon et al. 2004 Drag Partition Correction + ! + ! R = 1.0 - log(z0 / z0s) / log( 0.7 * (12255./z0s) ** 0.8) + ! + !-------------------------------------------------------------------------- + ! Drag partition correction. See MacKinnon et al. (2004), + ! doi:10.1016/j.geomorph.2004.03.009 + R = 1.0 - log(z0 / z0s) / log( 0.7 * (12255./z0s) ** 0.8) + + ! Drag partition correction. See Marticorena et al. (1997), + ! doi:10.1029/96JD02964 + !R = 1.0 - log(z0 / z0s) / log( 0.7 * (10./z0s) ** 0.8) + + return + end subroutine fengsha_drag + + subroutine fengsha_hflux(data,ust,utst, kvh, salt) + !--------------------------------------------------------------------- + ! Function: Calculates the Horizontal Saltation Flux, Q, and then + ! calculates the vertical flux. + ! + ! formula of Draxler & Gillette (2001) Atmos. Environ. + ! F = K A (r/g) U* ( U*^2 - Ut*^2 ) + ! + ! where: + ! F = vertical emission flux [g/m**2-s] + ! K = constant 2.0E-04 [1/m] + ! A = 0~3.5 mean = 2.8 (fudge factor) + ! U* = friction velocity [m/s] + ! Ut* = threshold friction velocity [m/s] + ! + !-------------------------------------------------------------------- + implicit none + type(smoke_data), intent(inout) :: data + real(kind_phys), intent(in) :: ust, & ! friction velocity + utst, & ! threshold friction velocity + kvh ! vertical to horizontal mass flux ratio + + real(kind_phys), intent(out) :: salt + real(kind_phys) :: Q + Q = ust * (ust * ust - utst * utst) + salt = Q ! sdep * kvh * Q + + return + end subroutine fengsha_hflux + + +end module dust_fengsha_mod diff --git a/smoke/module_add_emiss_burn.F90 b/smoke/module_add_emiss_burn.F90 new file mode 100755 index 000000000..5d5e63b21 --- /dev/null +++ b/smoke/module_add_emiss_burn.F90 @@ -0,0 +1,223 @@ +module module_add_emiss_burn +!RAR: significantly modified for the new BB emissions + use machine , only : kind_phys + use rrfs_smoke_data + use rrfs_smoke_config +CONTAINS + subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & + chem,julday,gmt,xlat,xlong, & + !luf_igbp,lu_fire1, & + vegtype,vfrac,peak_hr, & + time_int,ebu, & ! RAR + r_q,fhist,aod3d_smoke,aod3d_dust, & + ! nwfa,nifa, & + rainc,rainnc, swdown,smoke_forecast, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! USE module_configure, only: grid_config_rec_type +! USE module_state_description + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: ktau, julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + real(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + + real(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: ebu + + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong, rainc,rainnc,swdown, peak_hr, vfrac + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: r_q ! RAR: + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fhist ! RAR: + real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(OUT) :: aod3d_smoke, aod3d_dust ! RAR: + integer, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: vegtype + + real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: dz8w,rho_phy,rel_hum +! real(kind_phys), DIMENSION(ims:ime,1:nlcat,jms:jme), INTENT(IN) :: luf_igbp + +! real(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & +! OPTIONAL, INTENT(INOUT ) :: nwfa,nifa ! RAR: + + real(kind_phys), INTENT(IN) :: dtstep, gmt + real(kind_phys), INTENT(IN) :: time_int ! RAR: time in seconds since start of simulation + logical, INTENT(IN) :: smoke_forecast + + integer :: i,j,k,n,m + real(kind_phys) :: conv_rho, conv, ext2, dm_smoke, daero_num_wfa, daero_num_ifa !, lu_sum1_5, lu_sum12_14 + !real(kind_phys) :: ebumax +! CHARACTER (LEN=80) :: message + + INTEGER, PARAMETER :: kfire_max=35 ! max vertical level for BB plume rise + ! Diameters and standard deviations for emissions + ! the diameters are the volume (mass) geometric mean diameters, following MADE_SORGAM + real(kind_phys), PARAMETER :: dgvem_i= 0.08E-6 !0.03E-6 ! [ m ] + real(kind_phys), PARAMETER :: sgem_i = 1.8 !1.7 + + ! *** Accumulation mode: + real(kind_phys), PARAMETER :: dgvem_j= 0.3E-6 ! [ m ] + real(kind_phys), PARAMETER :: sgem_j = 2.0 + + ! *** Coarse mode + real(kind_phys), PARAMETER :: dgvem_c= 6.0E-6 ! [ m ] + real(kind_phys), PARAMETER :: sgem_c= 2.2 + real(kind_phys), PARAMETER :: pic= 3.14159 + + ! RAR: factors for getting number emissions rate from mass emissions rate following made_sorgam + real(kind_phys), PARAMETER :: fact_numn= 1.e-9*6.0/pic*exp(4.5*log(sgem_i)**2)/dgvem_i**3 ! Aitken mode + real(kind_phys), PARAMETER :: fact_numa= 1.e-9*6.0/pic*exp(4.5*log(sgem_j)**2)/dgvem_j**3 ! accumulation mode + real(kind_phys), PARAMETER :: fact_numc= 1.e-9*6.0/pic*exp(4.5*log(sgem_c)**2)/dgvem_c**3 ! coarse mode + + real(kind_phys), PARAMETER :: dens_oc_aer=1.4e3, dens_ec_aer=1.7e3 ! kg/m3 +! real(kind_phys), PARAMETER :: rinti=2.1813936e-8, cx=2.184936* 3600, timeq_max=3600.*24. ! constants for the diurnal cycle calculations + real(kind_phys), PARAMETER :: ax1=531., cx1=7800. ! For cropland, urban and small fires +! real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3200., const2=100., coef2=10.6712963e-4, cx=2.184936* 3600, timeq_max=3600.*24. + real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3400., const2=130., coef2=10.6712963e-4, cx2=7200., timeq_max=3600.*24. ! New parameters + real(kind_phys), PARAMETER :: sc_me= 4.0, ab_me=0.5 ! m2/g, scattering and absorption efficiency for smoke + +! Parameters used for the wfa and ifa in mp physics per Trude E. (NCAR) +! Water friendly: radius: 0.04 micron, standard deviation: 1.8, kappa (for hygroscopic growth): 0.2, real index of refraction: 1.53, imaginary index of refraction: 1e-7 +! Ice friendly: radius: 0.4 micron, standard deviation: 1.8, kappa : 0.04, real index of refraction: 1.56, imaginary index of refraction: 3e-3 + + ! real, parameter :: cx = 2.184936 * 3600., rinti = 2.1813936e-8 , ax = 2000.6038 + ! bx_bburn = 20.041288 * 3600., RAR: this depends on the vegetation class, location (local time) etc. + real(kind_phys) :: timeq, dt1,dt2,dtm ! For BB emis. diurnal cycle calculation + + timeq= gmt*3600. + real(time_int,4) + timeq= mod(timeq,timeq_max) + +! Main loops to add BB emissions + do j=jts,jte + do i=its,ite + !if( luf_igbp(i,17,j)>0.99 .OR. ebu(i,1,j,p_ebu_smoke) < 1.e-6) cycle ! no BB emissions or water pixels + if( (1.-vfrac (i,j))>0.99 .OR. ebu(i,1,j) < 1.e-6) cycle ! no BB emissions or water pixels + + ! RAR: the decrease in the BB emissions after >18 hrs of forecast, the decrease occurs at night. The decrease occurs at night. + IF (time_int>64800. .AND. swdown(i,j)<.1 .AND. fhist(i,j)>.75 ) THEN + fhist(i,j)= 0.75 + ENDIF + + IF (time_int>129600. .AND. swdown(i,j)<.1 .AND. fhist(i,j)>.5 ) THEN ! After 36 hr forecast + fhist(i,j)= 0.5 + ENDIF + + IF ( (rainc(i,j) + rainnc(i,j))>=10. .AND. fhist(i,j)>.3 ) THEN ! If it rains more than 1cm, then the BB emissions are reduced + fhist(i,j)= 0.3 + ENDIF + +! RAR: Grasslands (29% of ther western HRRR CONUS domain) probably also need to be added below, check this later +! RAR: In the HRRR CONUS domain (western part) crop 11%, 2% cropland/natural vegetation and 0.4% urban of pixels +!.OR. lu_index(i,j)==14) then ! Croplands(12), Urban and Built-Up(13), cropland/natural vegetation (14) mosaic in MODI-RUC vegetation classes +! Peak hours for the fire activity depending on the latitude +! if (xlong(i,j)<-130.) then max_ti= 24.041288* 3600. ! peak at 24 UTC, fires in Alaska +! elseif (xlong(i,j)<-100.) then max_ti= 22.041288* 3600. ! peak at 22 UTC, fires in the western US +! elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in the eastern US, max_ti= 20.041288* 3600. +! else max_ti= 18.041288* 3600. +! endif + + !IF ( lu_fire1(i,j)>0.9 ) then !Ag, urban fires, bare land etc. + IF ( vegtype(i,j)==12 .or. vegtype(i,j)==13 ) then !Ag, urban fires, bare land etc. + ! these fires will have exponentially decreasing diurnal cycle, these fires decrease 55% in 2 hours, end in 5 hours + r_q(i,j) = rinti* ax1 * exp(- (time_int**2)/(cx1**2) ) + ELSE + ! RAR: Gaussian profile for wildfires + dt1= abs(timeq - peak_hr(i,j)) + dt2= timeq_max - peak_hr(i,j) + timeq ! peak hour is always <86400. + dtm= MIN(dt1,dt2) + r_q(i,j) = rinti*( ax2 * exp(- dtm**2/(2.*cx2**2) ) + const2 - coef2*timeq ) + ENDIF + + r_q(i,j) = fhist(i,j)* max(0.,r_q(i,j)*timeq_max) + + !IF (swdown(i,j)<.1) THEN + ! r_q(i,j)= MIN(0.5,r_q(i,j)) ! lower BB emissions at night + !ENDIF + + !IF (.NOT. config_flags%bb_dcycle) THEN + !IF (.NOT. bb_dcycle) THEN + ! r_q(i,j)= fhist(i,j) ! no diurnal cycle + !END IF + + !IF (.NOT. smoke_forecast) THEN + r_q(i,j)= 1. + !END IF + + do k=kts,kfire_max + conv= r_q(i,j)*dtstep/(rho_phy(i,k,j)* dz8w(i,k,j)) + + ! RAR: in this case tracer_1 is fire emitted CO + ! conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + ! chem(i,k,j,p_tracer_1) = chem(i,k,j,p_tracer_1) + ebu(i,k,j,p_ebu_co)*conv_rho + +! dm_oc_bb = conv* ebu(i,k,j,p_ebu_oc) ! Assume that BB primary PM25 is mostly OC, 1.25 is OM/OC ratio +! dm_p25_bb= conv* ebu(i,k,j,p_ebu_pm25) +! dm_ec_bb = conv* ebu(i,k,j,p_ebu_bc) +! dm_smk = conv* ebu(i,k,j,p_ebu_smoke) + !IF (k==kts) THEN ! Partition takes place here to avoid double counting of smold. and flam. BB emiss. + ! C11= (1.-flam_frac(i,j))*r_q(i,j) + !ELSE + ! C11= flam_frac(i,j)*r_q(i,j) + !ENDIF + dm_smoke= conv*ebu(i,k,j) +! print*,'hli dm_smoke',dm_smoke,conv,ebu(i,k,j,p_ebu_smoke) + + chem(i,k,j,p_smoke) = chem(i,k,j,p_smoke) + dm_smoke + chem(i,k,j,p_smoke) = MIN(chem(i,k,j,p_smoke),5.e+3) + + if (ktau<1000 .and. dbg_opt) then + ! if ( k==kts ) then + ! WRITE(6,*) 'add_emiss_burn: ktau,gmt,dtstep,time_int ',ktau,gmt,dtstep,time_int + ! WRITE(*,*) 'add_emiss_burn: i,j,xlat(i,j),xlong(i,j) ',i,j,xlat(i,j),xlong(i,j) + !WRITE(*,*) 'add_emiss_burn: luf_igbp(i,:,j) ',luf_igbp(i,:,j) + !WRITE(*,*) 'add_emiss_burn: lu_fire1(i,j) ',lu_fire1(i,j) + ! WRITE(6,*) 'add_emiss_burn: timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) ',timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) + ! WRITE(*,*) 'add_emiss_burn: rainc(i,j),rainnc(i,j) ', rainc(i,j),rainnc(i,j) + ! endif + if ( k==kts .OR. k==kfire_max ) then + WRITE(6,*) 'add_emiss_burn: i,j,k ',i,j,k + WRITE(6,*) 'add_emiss_burn: rho_phy(i,k,j),dz8w(i,k,j),conv ',rho_phy(i,k,j),dz8w(i,k,j),conv + WRITE(6,*) 'add_emiss_burn: ebu(i,k,j),dm_smoke ', ebu(i,k,j),dm_smoke + endif + endif + + enddo + enddo + enddo + + ext2= sc_me + ab_me + do j=jts,jte + do k=kts,kte + do i=its,ite + + ! Check for NaNs, negative and too large numbers + IF (.NOT. (chem(i,k,j,p_smoke)>=0. .AND. chem(i,k,j,p_smoke)<1.1e+4)) THEN + chem(i,k,j,p_smoke)=1.e-16 + END IF + + aod3d_smoke(i,k,j)= 1.e-6* ext2* chem(i,k,j,p_smoke )*rho_phy(i,k,j)*dz8w(i,k,j) + aod3d_dust (i,k,j)= 1.e-6* ext2* chem(i,k,j,p_dust_1)*rho_phy(i,k,j)*dz8w(i,k,j) + enddo + enddo + enddo + + IF ( ktau<2000 .and. dbg_opt ) then + WRITE(*,*) 'add_emis_burn: i,j,k,ext2 ',i,j,k,ext2 + WRITE(*,*) 'add_emis_burn: rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) ',rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) + WRITE(*,*) 'add_emis_burn: aod3d_smoke(its,kts,jts),aod3d_smoke(ite,kfire_max,jte) ',aod3d_smoke(its,kts,jts),aod3d_smoke(ite,kfire_max,jte) + WRITE(*,*) 'add_emis_burn: aod3d_dust(its,kts,jts),aod3d_dust(ite,kfire_max,jte) ',aod3d_dust(its,kts,jts),aod3d_dust(ite,kfire_max,jte) + END IF + +! CASE DEFAULT +! call wrf_debug(15,'nothing done with burn emissions for chem array') +! END SELECT emiss_select + + END subroutine add_emis_burn + +END module module_add_emiss_burn diff --git a/smoke/module_plumerise1.F90 b/smoke/module_plumerise1.F90 new file mode 100755 index 000000000..ea2c4e3f7 --- /dev/null +++ b/smoke/module_plumerise1.F90 @@ -0,0 +1,211 @@ + module module_plumerise1 + + use rrfs_smoke_data + use machine , only : kind_phys +!- Implementing the fire radiative power (FRP) methodology for biomass burning +!- emissions and convective energy estimation. +!- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) +!- Ravan Ahmadov, Georg Grell (NOAA, USA) +!- The flag "plumerise_flag" defines the method: +!- =1 => original method +!- =2 => FRP based +!------------------------------------------------------------------------- +! +! use module_zero_plumegen_coms +! integer, parameter :: nveg_agreg = 4 +! integer, parameter :: tropical_forest = 1 +! integer, parameter :: boreal_forest = 2 +! integer, parameter :: savannah = 3 + +! integer, parameter :: grassland = 4 +! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct +! character(len=20), parameter :: veg_name(nveg_agreg) = (/ & +! 'Tropical-Forest', & +! 'Boreal-Forest ', & +! 'Savanna ', & +! 'Grassland ' /) +! character(len=20), parameter :: spc_suf(nveg_agreg) = (/ & +! 'agtf' , & ! trop forest +! 'agef' , & ! extratrop forest +! 'agsv' , & ! savanna +! 'aggr' /) ! grassland + +CONTAINS +subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & + t_phy,q_vap, & ! RAR: moist is replaced with q_vap + rho_phy,vvel,u_phy,v_phy,p_phy, & + z_at_w,z,ktau, & ! scale_fire_emiss is part of config_flags + plume_frp, k_min, k_max, & ! RAR: + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + use rrfs_smoke_config + use physcons + use plume_data_mod + USE module_zero_plumegen_coms + USE module_smoke_plumerise + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + + REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to have plume rise + + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme, 2 ), INTENT(IN ) :: plume_frp ! RAR: FRP etc. array + +! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: ktau, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte +! real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & +! INTENT(IN ) :: moist + real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT ) :: ebu + + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ebb_smoke + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: flam_frac + +! real(kind=kind_phys), DIMENSION( ims:ime, 1, jms:jme ), & +! INTENT(IN ) :: ebu_in +! real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), & +! INTENT(IN ) :: & +! mean_fct_agtf,mean_fct_agef,& +! mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef, & +! firesize_agsv,firesize_aggr + + real(kind=kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: t_phy,z,z_at_w,vvel,u_phy,v_phy,rho_phy,p_phy,q_vap ! RAR + ! real(kind=kind_phys), INTENT(IN ) :: dtstep + +! Local variables... + INTEGER :: nv, i, j, k, kp1, kp2 + INTEGER, DIMENSION(ims:ime, jms:jme), INTENT (OUT) :: k_min, k_max ! Min and max ver. levels for BB injection spread + !real(kind_phys), dimension (num_ebu) :: eburn_in + !real(kind_phys), dimension (kte,num_ebu) :: eburn_out + real(kind_phys), dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in, rho_phyin ,qv_in ,zmid, z_lev + real(kind=kind_phys) :: dz_plume + + !INTEGER, PARAMETER :: kfire_max=30 +! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct +! real(kind_phys) :: sum, ffirs, ratio +! real(kind_phys),save,dimension(its:ite,jts:jte) :: ffirs +! nspecies=num_ebu +! write(0,*)'plumerise' + +! RAR: +! if (config_flags%biomass_burn_opt == BIOMASSB_SMOKE) then +! do j=jts,jte: +! do i=its,ite +! ebu(i,kts,j,p_ebu_smoke)= ebb_smoke(i,j) +! ebu(i,kts,j,p_ebu_no) = ebu_in(i,1,j,p_ebu_in_no) +! ebu(i,kts,j,p_ebu_co) = ebu_in(i,1,j,p_ebu_in_co) +! ebu(i,kts,j,p_ebu_so2) = ebu_in(i,1,j,p_ebu_in_so2) +! ebu(i,kts,j,p_ebu_dms) = ebu_in(i,1,j,p_ebu_in_dms) +! ebu(i,kts,j,p_ebu_oc) = ebu_in(i,1,j,p_ebu_in_oc) +! ebu(i,kts,j,p_ebu_bc) = ebu_in(i,1,j,p_ebu_in_bc) +! ebu(i,kts,j,p_ebu_pm25) = ebu_in(i,1,j,p_ebu_in_pm25) +! ebu(i,kts,j,p_ebu_pm10) = ebu_in(i,1,j,p_ebu_in_pm10) +! enddo +! enddo + + IF ( dbg_opt .and. ktau<2000) then + WRITE(*,*) 'module_plumerise1: its,ite,jts,jte ', its,ite,jts,jte + WRITE(*,*) 'module_plumerise1: ims,ime,jms,jme ', ims,ime,jms,jme + !WRITE(*,*) 'module_plumerise1: p_ebu_smoke,num_ebu: ', p_ebu_smoke,num_ebu + WRITE(*,*) 'module_plumerise1: maxval(ebu(:,kts,:)) ', maxval(ebu(:,kts,:)) + END IF + !endif + +! RAR: setting to zero the ebu emissions at the levels k>1, this is necessary when the plumerise is called, so the emissions at k>1 are updated + !do nv=1,num_ebu + do j=jts,jte + do k=kts+1,kte + do i=its,ite + ebu(i,k,j)=0. + enddo + enddo + enddo + !enddo + +! For now the flammable fraction is constant, based on the namelist. The next +! step to use LU index and meteorology to parameterize it +! IF (ktau==2) THEN + do j=jts,jte + do i=its,ite + flam_frac(i,j)= 0. + if (plume_frp(i,j,1) > frp_threshold) then + flam_frac(i,j)= 0.9 + end if + enddo + enddo + ! ENDIF + + +! RAR: new FRP based approach +!check_pl: IF (config_flags%plumerise_flag == 2 ) THEN ! if the namelist option is set for plumerise +! Haiqin: plumerise_flag is added to the namelist options +!check_pl: IF (do_plumerise) THEN ! if the namelist option is set for plumerise + do j=jts,jte + do i=its,ite + ! k_min(i,j)=0 + ! k_max(i,j)=0 + +! check_frp: if (.NOT.do_plumerise) then ! namelist option +! ebu(i,kts,j)= ebb_smoke(i,j) +! else + + do k=kts,kte + u_in(k)= u_phy(i,k,j) + v_in(k)= v_phy(i,k,j) + w_in(k)= vvel(i,k,j) + qv_in(k)= q_vap(i,k,j) ! RAR: moist(i,k,j,p_qv) + !pi_in(k)= cp*(p_phy(i,k,j)/p1000mb)**rcp + pi_in(k)= con_cp*(p_phy(i,k,j)/p1000mb)**con_rocp + zmid(k)= z(i,k,j)-z_at_w(i,kts,j) + z_lev(k)= z_at_w(i,k,j)-z_at_w(i,kts,j) + rho_phyin(k)= rho_phy(i,k,j) + theta_in(k)= t_phy(i,k,j)/pi_in(k)*con_cp + !theta_in(k)= t_phy(i,k,j)/pi_in(k)*cp + enddo + + IF (dbg_opt .and. ktau<2000) then + WRITE(*,*) 'module_plumerise1: i,j ',i,j + WRITE(*,*) 'module_plumerise1: plume_frp(i,j,:) ',plume_frp(i,j,:) + WRITE(*,*) 'module_plumerise1: ebu(i,kts,j) ',ebu(i,kts,j) + WRITE(*,*) 'module_plumerise1: u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) ',u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) + WRITE(*,*) 'module_plumerise1: zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) ',zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) + WRITE(*,*) 'module_plumerise1: t_phy(i,kte,j),pi_in(kte)',t_phy(i,kte,j),pi_in(kte) + END IF + +! RAR: the plume rise calculation step: + CALL plumerise(data,kte,1,1,1,1,1,1, & + !firesize,mean_fct, & + !num_ebu, eburn_in, eburn_out, & + u_in, v_in, w_in, theta_in ,pi_in, & + rho_phyin, qv_in, zmid, z_lev, & + plume_frp(i,j,1), k_min(i,j), & + k_max(i,j), ktau, dbg_opt ) + !k_max(i,j), ktau, config_flags%debug_chem ) + + kp1= k_min(i,j) + kp2= k_max(i,j) + dz_plume= z_at_w(i,kp2,j) - z_at_w(i,kp1,j) + + do k=kp1,kp2-1 + ebu(i,k,j)= flam_frac(i,j)* ebb_smoke(i,j)* (z_at_w(i,k+1,j)-z_at_w(i,k,j))/dz_plume + enddo + ebu(i,kts,j)= (1.-flam_frac(i,j))* ebb_smoke(i,j) + + IF ( dbg_opt .and. ktau<2000) then + WRITE(*,*) 'module_plumerise1: i,j ',i,j + WRITE(*,*) 'module_plumerise1: k_min(i,j), k_max(i,j) ',k_min(i,j), k_max(i,j) + END IF +! endif check_frp + enddo + enddo + +! ENDIF check_pl + +end subroutine ebu_driver + +END module module_plumerise1 diff --git a/smoke/module_smoke_plumerise.F90 b/smoke/module_smoke_plumerise.F90 new file mode 100755 index 000000000..f31759404 --- /dev/null +++ b/smoke/module_smoke_plumerise.F90 @@ -0,0 +1,2345 @@ +!------------------------------------------------------------------------- +!- 12 April 2016 +!- Implementing the fire radiative power (FRP) methodology for biomass burning +!- emissions and convective energy estimation. +!- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) +!- Ravan Ahmadov, Georg Grell (NOAA, USA) +!- The flag "plumerise_flag" defines the method: +!- =1 => original method +!- =2 => FRP based +!------------------------------------------------------------------------- +module module_smoke_plumerise + + use machine , only : kind_phys + use rrfs_smoke_data + use rrfs_smoke_config, only : FIRE_OPT_GBBEPx, FIRE_OPT_MODIS + use physcons, only : g => con_g, cp => con_cp, r_d => con_rd, r_v =>con_rv + use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std, & + !tropical_forest, boreal_forest, savannah, grassland, & + wind_eff + USE module_zero_plumegen_coms + + real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) + real(kind=kind_phys),parameter :: rgas=r_d + real(kind=kind_phys),parameter :: cpor=cp/r_d + real(kind=kind_phys),parameter :: p00=p1000mb +CONTAINS + +! RAR: + subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & +! firesize,mean_fct, & + ! nspecies,eburn_in,eburn_out, & + up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & + frp_inst,k1,k2, ktau, dbg_opt ) + + implicit none + type(smoke_data), intent(inout) :: data + + LOGICAL, INTENT (IN) :: dbg_opt + +! INTEGER, PARAMETER :: ihr_frp=1, istd_frp=2!, imean_fsize=3, istd_fsize=4 ! RAR: + +! integer, intent(in) :: PLUMERISE_flag + real(kind=kind_phys) :: frp_inst ! This is the instantenous FRP, at a given time step + + integer :: ng,m1,m2,m3,ia,iz,ja,jz,ibcon,mynum,i,j,k,imm,ixx,ispc !,nspecies + + INTEGER, INTENT (IN) :: ktau + INTEGER, INTENT (OUT) :: k1,k2 + +! integer :: ncall = 0 + integer :: kmt +! real(kind=kind_phys),dimension(m1,nspecies), intent(inout) :: eburn_out +! real(kind=kind_phys),dimension(nspecies), intent(in) :: eburn_in + + real(kind=kind_phys), dimension(m1,m2,m3) :: up, vp, wp,theta,pp,dn0,rv + real(kind=kind_phys), dimension(m1) :: zt_rams,zm_rams + real(kind=kind_phys) :: burnt_area,dzi,FRP ! RAR: + real(kind=kind_phys), dimension(2) :: ztopmax + real(kind=kind_phys) :: q_smold_kgm2 + + REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to have plume rise + +! From plumerise1.F routine + integer, parameter :: iveg_ag=1 +! integer, parameter :: tropical_forest = 1 +! integer, parameter :: boreal_forest = 2 +! integer, parameter :: savannah = 3 +! integer, parameter :: grassland = 4 +! real(kind=kind_phys), dimension(nveg_agreg) :: firesize,mean_fct + + INTEGER, PARAMETER :: wind_eff = 1 + + type(plumegen_coms), pointer :: coms + +! integer:: iloop + !REAL(kind=kind_phys), INTENT (IN) :: convert_smold_to_flam + + !Fator de conversao de unidades + !!fcu=1. !=> kg [gas/part] /kg [ar] + !!fcu =1.e+12 !=> ng [gas/part] /kg [ar] + !!real(kind=kind_phys),parameter :: fcu =1.e+6 !=> mg [gas/part] /kg [ar] + !---------------------------------------------------------------------- + ! indexacao para o array "plume(k,i,j)" + ! k + ! 1 => area media (m^2) dos focos em biomas floresta dentro do gribox i,j + ! 2 => area media (m^2) dos focos em biomas savana dentro do gribox i,j + ! 3 => area media (m^2) dos focos em biomas pastagem dentro do gribox i,j + ! 4 => desvio padrao da area media (m^2) dos focos : floresta + ! 5 => desvio padrao da area media (m^2) dos focos : savana + ! 6 => desvio padrao da area media (m^2) dos focos : pastagem + ! 7 a 9 => sem uso + !10(=k_CO_smold) => parte da emissao total de CO correspondente a fase smoldering + !11, 12 e 13 => este array guarda a relacao entre + ! qCO( flaming, floresta) e a quantidade total emitida + ! na fase smoldering, isto e; + ! qCO( flaming, floresta) = plume(11,i,j)*plume(10,i,j) + ! qCO( flaming, savana ) = plume(12,i,j)*plume(10,i,j) + ! qCO( flaming, pastagem) = plume(13,i,j)*plume(10,i,j) + !20(=k_PM25_smold),21,22 e 23 o mesmo para PM25 + ! + !24-n1 => sem uso + !---------------------------------------------------------------------- +! print *,' Plumerise_scalar 1',ncall + coms => get_thread_coms() + if (ktau==2) then + call coms%set_to_zero() + endif + +IF (frp_inst there is not emission with + !- plume rise => cycle + + do k = 1,m1 ! loop over vertical grid + coms%ucon (k)=up(k,i,j) ! u wind + coms%vcon (k)=vp(k,i,j) ! v wind + !coms%wcon (k)=wp(k,i,j) ! w wind + coms%thtcon(k)=theta(k,i,j) ! pot temperature + coms%picon (k)=pp(k,i,j) ! exner function + !coms%tmpcon(k)=coms%thtcon(k)*coms%picon(k)/cp ! temperature (K) + !coms%dncon (k)=dn0(k,i,j) ! dry air density (basic state) + !coms%prcon (k)=(coms%picon(k)/cp)**cpor*p00 ! pressure (Pa) + coms%rvcon (k)=rv(k,i,j) ! water vapor mixing ratio + coms%zcon (k)=zt_rams(k) ! termod-point height + coms%zzcon (k)=zm_rams(k) ! W-point height + enddo + +! do ispc=2,nspecies + ! eburn_out(1,ispc) = eburn_in(ispc) ! eburn_in is the emissions at the 1st level +! eburn_out(2:m1,ispc)= 0. ! RAR: k>1 are used from eburn_out +! enddo + + !- get envinronmental state (temp, water vapor mix ratio, ...) + call get_env_condition(coms,1,m1,kmt,wind_eff,ktau) + + !- loop over the four types of aggregate biomes with fires for plumerise version 1 + !- for plumerise version 2, there is exist only one loop + ! iloop=1 +! IF (PLUMERISE_flag == 1) iloop=nveg_agreg + + !lp_veg: do iveg_ag=1,iloop + FRP = max(1000.,frp_inst) + + !- loop over the minimum and maximum heat fluxes/FRP + lp_minmax: do imm=1,2 + if(imm==1 ) then + burnt_area = 0.7* 0.00021* FRP ! - 0.5*plume_fre(istd_fsize)) + elseif(imm==2 ) then + burnt_area = 1.3* 0.00021* FRP + endif + burnt_area= max(1.0e4,burnt_area) + + IF (dbg_opt .AND. ktau<2000) THEN + WRITE(*,*) 'plumerise: m1,ktau ', m1,ktau + WRITE(*,*) 'plumerise: imm, FRP,burnt_area ', imm, FRP,burnt_area + ! WRITE(*,*) 'convert_smold_to_flam ',convert_smold_to_flam + WRITE(*,*) 'plumerise: zcon ', coms%zcon + WRITE(*,*) 'plumerise: zzcon ', coms%zzcon + END IF + + IF (dbg_opt .AND. ktau<2000) then + WRITE(*,*) 'plumerise: imm ', imm + WRITE(*,*) 'plumerise: burnt_area ',burnt_area + END IF + + !- get fire properties (burned area, plume radius, heating rates ...) + call get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP) + + !------ generates the plume rise ------ + call makeplume (coms,kmt,ztopmax(imm),ixx,imm) + + IF (dbg_opt .AND. ktau<2000) then + WRITE(*,*) 'plumerise after makeplume: imm,kmt,ztopmax(imm) ',imm,kmt,ztopmax(imm) + END IF + + enddo lp_minmax + + !- define o dominio vertical onde a emissao flaming ira ser colocada + call set_flam_vert(ztopmax,k1,k2,nkp,coms%zzcon) !,W_VMD,VMD) + + ! IF (ktau<2000) then + ! WRITE(6,*) 'module_chem_plumerise_scalar: eburn_out(:,3) ', eburn_out(:,3) + ! END IF + + !- thickness of the vertical layer between k1 and k2 eta levels (lower and upper bounds for the injection height ) + !dzi= 1./(coms%zzcon(k2)-coms%zzcon(k1)) ! RAR: k2>=k1+1 + + !- emission during flaming phase is evenly distributed between levels k1 and k2 + !do k=k1,k2 + ! do ispc= 2,nspecies + ! eburn_out(k,ispc)= dzi* eburn_in(ispc) + ! enddo + !enddo + + IF (dbg_opt .AND. ktau<2000) then + WRITE(*,*) 'plumerise after set_flam_vert: nkp,k1,k2, ', nkp,k1,k2 + WRITE(*,*) 'plumerise after set_flam_vert: dzi ', dzi + !WRITE(*,*) 'plumerise after set_flam_vert: eburn_in(2) ', eburn_in(2) + !WRITE(*,*) 'plumerise after set_flam_vert: eburn_out(:,2) ',eburn_out(:,2) + END IF + +! enddo lp_veg ! sub-grid vegetation, currently it's aggregated + +end subroutine plumerise +!------------------------------------------------------------------------- + +subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau) + +!se module_zero_plumegen_coms +!use rconstants +implicit none +type(plumegen_coms), pointer :: coms +integer :: k1,k2,k,kcon,klcl,kmt,nk,nkmid,i +real(kind=kind_phys) :: znz,themax,tlll,plll,rlll,zlll,dzdd,dzlll,tlcl,plcl,dzlcl,dummy +!integer :: n_setgrid = 0 +integer :: wind_eff,ktau + +if(ktau==2) then + ! n_setgrid = 1 + call set_grid(coms) ! define vertical grid of plume model + ! coms%zt(k) = thermo and water levels + ! coms%zm(k) = dynamical levels +endif + +znz=coms%zcon(k2) +do k=nkp,1,-1 + if(coms%zt(k).lt.znz)go to 13 +enddo +stop ' envir stop 12' +13 continue +!-srf-mb +kmt=min(k,nkp-1) + +nk=k2-k1+1 +!call htint(nk, coms%wcon,coms%zzcon,kmt,wpe,coms%zt) + call htint(nk, coms%ucon,coms%zcon,kmt,coms%upe,coms%zt) + call htint(nk, coms%vcon,coms%zcon,kmt,coms%vpe,coms%zt) + call htint(nk,coms%thtcon,coms%zcon,kmt,coms%the ,coms%zt) + call htint(nk, coms%rvcon,coms%zcon,kmt,coms%qvenv,coms%zt) +do k=1,kmt + coms%qvenv(k)=max(coms%qvenv(k),1e-8) +enddo + +coms%pke(1)=coms%picon(1) +do k=1,kmt + coms%thve(k)=coms%the(k)*(1.+.61*coms%qvenv(k)) ! virtual pot temperature +enddo +do k=2,kmt + coms%pke(k)=coms%pke(k-1)-g*2.*(coms%zt(k)-coms%zt(k-1)) & ! exner function + /(coms%thve(k)+coms%thve(k-1)) +enddo +do k=1,kmt + coms%te(k) = coms%the(k)*coms%pke(k)/cp ! temperature (K) + coms%pe(k) = (coms%pke(k)/cp)**cpor*p00 ! pressure (Pa) + coms%dne(k)= coms%pe(k)/(rgas*coms%te(k)*(1.+.61*coms%qvenv(k))) ! dry air density (kg/m3) +! print*,'ENV=',coms%qvenv(k)*1000., coms%te(k)-273.15,coms%zt(k) +!-srf-mb + coms%vel_e(k) = sqrt(coms%upe(k)**2+coms%vpe(k)**2) !-env wind (m/s) + !print*,'k,coms%vel_e(k),coms%te(k)=',coms%vel_e(k),coms%te(k) +enddo + +!-ewe - env wind effect +if(wind_eff < 1) coms%vel_e(1:kmt) = 0. + +!-use este para gerar o RAMS.out +! ------- print environment state +!print*,'k,coms%zt(k),coms%pe(k),coms%te(k)-273.15,coms%qvenv(k)*1000' +!do k=1,kmt +! write(*,100) k,coms%zt(k),coms%pe(k),coms%te(k)-273.15,coms%qvenv(k)*1000. +! 100 format(1x,I5,4f20.12) +!enddo +!stop 333 + + +!--------- nao eh necessario este calculo +!do k=1,kmt +! call thetae(coms%pe(k),coms%te(k),coms%qvenv(k),coms%thee(k)) +!enddo + + +!--------- converte press de Pa para kPa para uso modelo de plumerise +do k=1,kmt + coms%pe(k) = coms%pe(k)*1.e-3 +enddo + +return +end subroutine get_env_condition + +!------------------------------------------------------------------------- + +subroutine set_grid(coms) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer :: k,mzp + +coms%dz=100. ! set constant grid spacing of plume grid model(meters) + +mzp=nkp +coms%zt(1) = coms%zsurf +coms%zm(1) = coms%zsurf +coms%zt(2) = coms%zt(1) + 0.5*coms%dz +coms%zm(2) = coms%zm(1) + coms%dz +do k=3,mzp + coms%zt(k) = coms%zt(k-1) + coms%dz ! thermo and water levels + coms%zm(k) = coms%zm(k-1) + coms%dz ! dynamical levels +enddo +!print*,coms%zsurf +!Print*,coms%zt(:) +do k = 1,mzp-1 + coms%dzm(k) = 1. / (coms%zt(k+1) - coms%zt(k)) +enddo +coms%dzm(mzp)=coms%dzm(mzp-1) + +do k = 2,mzp + coms%dzt(k) = 1. / (coms%zm(k) - coms%zm(k-1)) +enddo +coms%dzt(1) = coms%dzt(2) * coms%dzt(2) / coms%dzt(3) + +! coms%dzm(1) = 0.5/coms%dz +! coms%dzm(2:mzp) = 1./coms%dz +return +end subroutine set_grid +!------------------------------------------------------------------------- + + SUBROUTINE set_flam_vert(ztopmax,k1,k2,nkp,zzcon) !,W_VMD,VMD) + + REAL(kind=kind_phys) , INTENT(IN) :: ztopmax(2) + INTEGER , INTENT(OUT) :: k1,k2 + + ! plumegen_coms + INTEGER , INTENT(IN) :: nkp + REAL(kind=kind_phys) , INTENT(IN) :: zzcon(nkp) + + INTEGER imm,k + INTEGER, DIMENSION(2) :: k_lim + + !- version 2 +! REAL(kind=kind_phys) , INTENT(IN) :: W_VMD(nkp,2) +! REAL(kind=kind_phys) , INTENT(OUT) :: VMD(nkp,2) +! real(kind=kind_phys) w_thresold,xxx +! integer k_initial,k_final,ko,kk4,kl + + !- version 1 + DO imm=1,2 + ! checar + ! do k=1,m1-1 + DO k=1,nkp-1 + IF(zzcon(k) > ztopmax(imm)) EXIT + ENDDO + k_lim(imm) = k + ENDDO + k1= MIN(MAX(4,k_lim(1)),51) + k2= MIN(51,k_lim(2)) ! RAR: the model doesn't simulate very high injection heights, so it's safe to assume maximum heigh of 12km AGL for HRRR grid + + IF (k2 <= k1) THEN + !print*,'1: ztopmax k=',ztopmax(1), k1 + !print*,'2: ztopmax k=',ztopmax(2), k2 + k2= k1+1 ! RAR: I added k1+1 + ENDIF + + !- version 2 + !- vertical mass distribution + !- +! w_thresold = 1. +! DO imm=1,2 + +! VMD(1:nkp,imm)= 0. +! xxx=0. +! k_initial= 0 +! k_final = 0 + + !- define range of the upper detrainemnt layer +! do ko=nkp-10,2,-1 + +! if(w_vmd(ko,imm) < w_thresold) cycle + +! if(k_final==0) k_final=ko + +! if(w_vmd(ko,imm)-1. > w_vmd(ko-1,imm)) then +! k_initial=ko +! exit +! endif + +! enddo + !- if there is a non zero depth layer, make the mass vertical distribution +! if(k_final > 0 .and. k_initial > 0) then + +! k_initial=int((k_final+k_initial)*0.5) + + !- parabolic vertical distribution between k_initial and k_final +! kk4 = k_final-k_initial+2 +! do ko=1,kk4-1 +! kl=ko+k_initial-1 +! VMD(kl,imm) = 6.* float(ko)/float(kk4)**2 * (1. - float(ko)/float(kk4)) +! enddo +! if(sum(VMD(1:NKP,imm)) .ne. 1.) then +! xxx= ( 1.- sum(VMD(1:NKP,imm)) )/float(k_final-k_initial+1) +! do ko=k_initial,k_final +! VMD(ko,imm) = VMD(ko,imm)+ xxx !- values between 0 and 1. +! enddo + ! print*,'new mass=',sum(mass)*100.,xxx + !pause +! endif +! endif !k_final > 0 .and. k_initial > + +! ENDDO + + END SUBROUTINE set_flam_vert +!------------------------------------------------------------------------- + +subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer :: moist, i, icount,imm,iveg_ag !,plumerise_flag +real(kind=kind_phys):: bfract, effload, heat, hinc ,burnt_area,heat_fluxW,FRP +real(kind=kind_phys), dimension(2,4) :: heat_flux +INTEGER, parameter :: use_last = 0 +!real(kind=kind_phys), parameter :: beta = 5.0 !ref.: Wooster et al., 2005 +REAL(kind=kind_phys), parameter :: beta = 0.88 !ref.: Paugam et al., 2015 + +data heat_flux/ & +!--------------------------------------------------------------------- +! heat flux !IGBP Land Cover ! +! min ! max !Legend and ! reference +! kW/m^2 !description ! +!-------------------------------------------------------------------- +30.0, 80.0, &! Tropical Forest ! igbp 2 & 4 +30.0, 80.0, &! Boreal(kind=kind_phys) forest ! igbp 1 & 3 +4.4, 23.0, &! cerrado/woody savanna | igbp 5 thru 9 +3.3, 3.3 /! Grassland/cropland ! igbp 10 thru 17 +!-------------------------------------------------------------------- +!-- fire at surface +! +!coms%area = 20.e+4 ! area of burn, m^2 +coms%area = burnt_area! area of burn, m^2 + +!IF ( PLUMERISE_flag == 1) THEN +! !fluxo de calor para o bioma +! heat_fluxW = heat_flux(imm,iveg_ag) * 1000. ! converte para W/m^2 + +!ELSEIF ( PLUMERISE_flag == 2) THEN + ! "beta" factor converts FRP to convective energy + heat_fluxW = beta*(FRP/coms%area)/0.55 ! in W/m^2 +! FIXME: These five lines were not in the known-working version. Delete them? +! if(coms%area<1e-6) then +! heat_fluxW = 0 +! else +! heat_fluxW = beta*(FRP/coms%area)/0.55 ! in W/m^2 +! endif + +!ENDIF + +coms%mdur = 53 ! duration of burn, minutes +coms%bload = 10. ! total loading, kg/m**2 +moist = 10 ! fuel moisture, %. average fuel moisture,percent dry +coms%maxtime =coms%mdur+2 ! model time, min +!heat = 21.e6 !- joules per kg of fuel consumed +!heat = 15.5e6 !joules/kg - cerrado +heat = 19.3e6 !joules/kg - floresta em alta floresta (mt) +!coms%alpha = 0.1 !- entrainment constant +coms%alpha = 0.05 !- entrainment constant + +!-------------------- printout ---------------------------------------- + +!!WRITE ( * , * ) ' SURFACE =', COMS%ZSURF, 'M', ' LCL =', COMS%ZBASE, 'M' +! +!PRINT*,'=======================================================' +!print * , ' FIRE BOUNDARY CONDITION :' +!print * , ' DURATION OF BURN, MINUTES =',COMS%MDUR +!print * , ' AREA OF BURN, HA =',COMS%AREA*1.e-4 +!print * , ' HEAT FLUX, kW/m^2 =',heat_fluxW*1.e-3 +!print * , ' TOTAL LOADING, KG/M**2 =',COMS%BLOAD +!print * , ' FUEL MOISTURE, % =',MOIST !average fuel moisture,percent dry +!print * , ' MODEL TIME, MIN. =',COMS%MAXTIME +! +! +! +! ******************** fix up inputs ********************************* +! + +!IF (MOD (COMS%MAXTIME, 2) .NE.0) COMS%MAXTIME = COMS%MAXTIME+1 !make coms%maxtime even + +COMS%MAXTIME = COMS%MAXTIME * 60 ! and put in seconds +! +COMS%RSURF = SQRT (COMS%AREA / 3.14159) !- entrainment surface radius (m) + +COMS%FMOIST = MOIST / 100. !- fuel moisture fraction +! +! +! calculate the energy flux and water content at lboundary. +! fills heating() on a minute basis. could ask for a file at this po +! in the program. whatever is input has to be adjusted to a one +! minute timescale. +! + + DO I = 1, ntime !- make sure of energy release + COMS%HEATING (I) = 0.0001 !- avoid possible divide by 0 + enddo +! + COMS%TDUR = COMS%MDUR * 60. !- number of seconds in the burn + + bfract = 1. !- combustion factor + + EFFLOAD = COMS%BLOAD * BFRACT !- patchy burning + +! spread the burning evenly over the interval +! except for the first few minutes for stability + ICOUNT = 1 +! + if(COMS%MDUR > NTIME) STOP 'Increase time duration (ntime) in min - see file "module_zero_plumegen_coms.F90"' + + DO WHILE (ICOUNT.LE.COMS%MDUR) +! COMS%HEATING (ICOUNT) = HEAT * EFFLOAD / COMS%TDUR ! W/m**2 +! COMS%HEATING (ICOUNT) = 80000. * 0.55 ! W/m**2 + + COMS%HEATING (ICOUNT) = heat_fluxW * 0.55 ! W/m**2 (0.55 converte para energia convectiva) + ICOUNT = ICOUNT + 1 + ENDDO +! ramp for 5 minutes + IF(use_last /= 1) THEN + + HINC = COMS%HEATING (1) / 4. + COMS%HEATING (1) = 0.1 + COMS%HEATING (2) = HINC + COMS%HEATING (3) = 2. * HINC + COMS%HEATING (4) = 3. * HINC + ELSE + IF(imm==1) THEN + HINC = COMS%HEATING (1) / 4. + COMS%HEATING (1) = 0.1 + COMS%HEATING (2) = HINC + COMS%HEATING (3) = 2. * HINC + COMS%HEATING (4) = 3. * HINC + ELSE + HINC = (COMS%HEATING (1) - heat_flux(imm-1,iveg_ag) * 1000. *0.55)/ 4. + COMS%HEATING (1) = heat_flux(imm-1,iveg_ag) * 1000. *0.55 + 0.1 + COMS%HEATING (2) = COMS%HEATING (1)+ HINC + COMS%HEATING (3) = COMS%HEATING (2)+ HINC + COMS%HEATING (4) = COMS%HEATING (3)+ HINC + ENDIF + ENDIF + +return +end subroutine get_fire_properties +!------------------------------------------------------------------------------- +! +SUBROUTINE MAKEPLUME (coms,kmt,ztopmax,ixx,imm) +! +! ********************************************************************* +! +! EQUATION SOURCE--Kessler Met.Monograph No. 32 V.10 (K) +! Alan Weinstein, JAS V.27 pp 246-255. (W), +! Ogura and Takahashi, Monthly Weather Review V.99,pp895-911 (OT) +! Roger Pielke,Mesoscale Meteorological Modeling,Academic Press,1984 +! Originally developed by: Don Latham (USFS) +! +! +! ************************ VARIABLE ID ******************************** +! +! DT=COMPUTING TIME INCREMENT (SEC) +! DZ=VERTICAL INCREMENT (M) +! LBASE=LEVEL ,CLOUD BASE +! +! CONSTANTS: +! G = GRAVITATIONAL ACCELERATION 9.80796 (M/SEC/SEC). +! R = DRY AIR GAS CONSTANT (287.04E6 JOULE/KG/DEG K) +! CP = SPECIFIC HT. (1004 JOULE/KG/DEG K) +! HEATCOND = HEAT OF CONDENSATION (2.5E6 JOULE/KG) +! HEATFUS = HEAT OF FUSION (3.336E5 JOULE/KG) +! HEATSUBL = HEAT OF SUBLIMATION (2.83396E6 JOULE/KG) +! EPS = RATIO OF MOL.WT. OF WATER VAPOR TO THAT OF DRY AIR (0.622) +! DES = DIFFERENCE BETWEEN VAPOR PRESSURE OVER WATER AND ICE (MB) +! TFREEZE = FREEZING TEMPERATURE (K) +! +! +! PARCEL VALUES: +! T = TEMPERATURE (K) +! TXS = TEMPERATURE EXCESS (K) +! QH = HYDROMETEOR WATER CONTENT (G/G DRY AIR) +! QHI = HYDROMETEOR ICE CONTENT (G/G DRY AIR) +! QC = WATER CONTENT (G/G DRY AIR) +! QVAP = WATER VAPOR MIXING RATIO (G/G DRY AIR) +! QSAT = SATURATION MIXING RATIO (G/G DRY AIR) +! RHO = DRY AIR DENSITY (G/M**3) MASSES = RHO*Q'S IN G/M**3 +! ES = SATURATION VAPOR PRESSURE (kPa) +! +! ENVIRONMENT VALUES: +! TE = TEMPERATURE (K) +! PE = PRESSURE (kPa) +! QVENV = WATER VAPOR (G/G) +! RHE = RELATIVE HUMIDITY FRACTION (e/esat) +! DNE = dry air density (kg/m^3) +! +! HEAT VALUES: +! HEATING = HEAT OUTPUT OF FIRE (WATTS/M**2) +! MDUR = DURATION OF BURN, MINUTES +! +! W = VERTICAL VELOCITY (M/S) +! RADIUS=ENTRAINMENT RADIUS (FCN OF Z) +! RSURF = ENTRAINMENT RADIUS AT GROUND (SIMPLE PLUME, TURNER) +! ALPHA = ENTRAINMENT CONSTANT +! MAXTIME = TERMINATION TIME (MIN) +! +! +!********************************************************************** +!********************************************************************** +!use module_zero_plumegen_coms +implicit none +!logical :: endspace +type(plumegen_coms), pointer :: coms +character (len=10) :: varn +integer :: izprint, iconv, itime, k, kk, kkmax, deltak,ilastprint,kmt & + ,ixx,nrectotal,i_micro,n_sub_step +real(kind=kind_phys) :: vc, g, r, cp, eps, & + tmelt, heatsubl, heatfus, heatcond, tfreeze, & + ztopmax, wmax, rmaxtime, es, esat, heat,dt_save !ESAT_PR, +character (len=2) :: cixx +! Set threshold to be the same as dz=100., the constant grid spacing of plume grid model(meters) found in set_grid() + REAL(kind=kind_phys) :: DELZ_THRESOLD = 100. + + INTEGER :: imm + +! real(kind=kind_phys), external:: esat_pr! +! +! ******************* SOME CONSTANTS ********************************** +! +! XNO=10.0E06 median volume diameter raindrop (K table 4) +! VC = 38.3/(XNO**.125) mean volume fallspeed eqn. (K) +! +parameter (vc = 5.107387) +parameter (g = 9.80796, r = 287.04, cp = 1004., eps = 0.622, tmelt = 273.3) +parameter (heatsubl = 2.834e6, heatfus = 3.34e5, heatcond = 2.501e6) +parameter (tfreeze = 269.3) +! +coms%tstpf = 2.0 !- timestep factor +coms%viscosity = 500.!- coms%viscosity constant (original value: 0.001) + +nrectotal=150 +! +!*************** PROBLEM SETUP AND INITIAL CONDITIONS ***************** +coms%mintime = 1 +ztopmax = 0. +coms%ztop = 0. + coms%time = 0. + coms%dt = 1. + wmax = 1. +kkmax = 10 +deltaK = 20 +ilastprint=0 +COMS%L = 1 ! COMS%L initialization + +!--- initialization +CALL INITIAL(coms,kmt) + +!--- initial print fields: +izprint = 0 ! if = 0 => no printout +!if (izprint.ne.0) then +! write(cixx(1:2),'(i2.2)') ixx +! open(2, file = 'debug.'//cixx//'.dat') +! open(19,file='plumegen9.'//cixx//'.gra', & +! form='unformatted',access='direct',status='unknown', & +! recl=4*nrectotal) !PC +! recl=1*nrectotal) !sx6 e tupay +! call printout (izprint,nrectotal) +! ilastprint=2 +!endif + +! ******************* model evolution ****************************** +rmaxtime = float(coms%maxtime) +! +!print * ,' TIME=',coms%time,' RMAXTIME=',rmaxtime +!print*,'=======================================================' + DO WHILE (COMS%TIME.LE.RMAXTIME) !beginning of time loop + +! do itime=1,120 + +!-- set model top integration + coms%nm1 = min(kmt, kkmax + deltak) +!sam 81 format('nm1=',I0,' from kmt=',I0,' kkmax=',I0,' deltak=',I0) +!sam write(0,81) coms%nm1,kmt,kkmax,deltak +!-- set timestep + !coms%dt = (coms%zm(2)-coms%zm(1)) / (coms%tstpf * wmax) + coms%dt = min(5.,(coms%zm(2)-coms%zm(1)) / (coms%tstpf * wmax)) + +!-- elapsed time, sec + coms%time = coms%time+coms%dt +!-- elapsed time, minutes + coms%mintime = 1 + int (coms%time) / 60 + wmax = 1. !no zeroes allowed. +!************************** BEGIN SPACE LOOP ************************** + +!-- zerout all model tendencies + call tend0_plumerise(coms) + +!-- bounday conditions (k=1) + COMS%L=1 + call lbound(coms) + +!-- dynamics for the level k>1 +!-- W advection +! call vel_advectc_plumerise(COMS%NM1,COMS%WC,COMS%WT,COMS%DNE,COMS%DZM) + call vel_advectc_plumerise(COMS%NM1,COMS%WC,COMS%WT,COMS%RHO,COMS%DZM) + +!-- scalars advection 1 + call scl_advectc_plumerise(coms,'SC',COMS%NM1) + +!-- scalars advection 2 + !call scl_advectc_plumerise2(coms,'SC',COMS%NM1) + +!-- scalars entrainment, adiabatic + call scl_misc(coms,COMS%NM1) + +!-- scalars dinamic entrainment + call scl_dyn_entrain(COMS%NM1,nkp,coms%wbar,coms%w,coms%adiabat,coms%alpha,coms%radius,coms%tt,coms%t,coms%te,coms%qvt,coms%qv,coms%qvenv,coms%qct,coms%qc,coms%qht,coms%qh,coms%qit,coms%qi,& + coms%vel_e,coms%vel_p,coms%vel_t,coms%rad_p,coms%rad_t) + +!-- gravity wave damping using Rayleigh friction layer fot COMS%T + call damp_grav_wave(1,coms%nm1,deltak,coms%dt,coms%zt,coms%zm,coms%w,coms%t,coms%tt,coms%qv,coms%qh,coms%qi,coms%qc,coms%te,coms%pe,coms%qvenv) + +!-- microphysics +! goto 101 ! bypass microphysics + dt_save=coms%dt + n_sub_step=3 + coms%dt=coms%dt/float(n_sub_step) + + do i_micro=1,n_sub_step +!-- sedim ? + call fallpart(coms,COMS%NM1) +!-- microphysics + coms%L=2 + do while(coms%L<=coms%nm1-1) + !do L=2,coms%nm1-1 + COMS%WBAR = 0.5*(coms%W(COMS%L)+coms%W(COMS%L-1)) + ES = ESAT_PR (COMS%T(COMS%L)) !BLOB SATURATION VAPOR PRESSURE, EM KPA + COMS%QSAT(COMS%L) = (EPS * ES) / (COMS%PE(COMS%L) - ES) !BLOB SATURATION LWC G/G DRY AIR + COMS%EST (COMS%L) = ES +!sam if(.not.coms%pe(coms%L)>0 .or. .not. coms%T(coms%L)>200) then +!sam 1304 format('(1304) bad input to rho at L=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1304) coms%L,coms%PE(coms%L),coms%T(coms%L) +!sam endif + COMS%RHO (COMS%L) = 3483.8 * COMS%PE (COMS%L) / COMS%T (COMS%L) ! AIR PARCEL DENSITY , G/M**3 +!srf18jun2005 +! IF (COMS%W(COMS%L) .ge. 0.) COMS%DQSDZ = (COMS%QSAT(COMS%L ) - COMS%QSAT(COMS%L-1)) / (COMS%ZT(COMS%L ) -COMS%ZT(COMS%L-1)) +! IF (COMS%W(COMS%L) .lt. 0.) COMS%DQSDZ = (COMS%QSAT(COMS%L+1) - COMS%QSAT(COMS%L )) / (COMS%ZT(COMS%L+1) -COMS%ZT(COMS%L )) + IF (COMS%W(COMS%L) .ge. 0.) then + COMS%DQSDZ = (COMS%QSAT(COMS%L+1) - COMS%QSAT(COMS%L-1)) / (COMS%ZT(COMS%L+1 )-COMS%ZT(COMS%L-1)) + ELSE + COMS%DQSDZ = (COMS%QSAT(COMS%L+1) - COMS%QSAT(COMS%L-1)) / (COMS%ZT(COMS%L+1) -COMS%ZT(COMS%L-1)) + ENDIF + + call waterbal(coms) + coms%L=coms%L+1 + enddo + enddo + coms%dt=dt_save +! + 101 continue +! +!-- W-viscosity for stability + call visc_W(coms,coms%nm1,deltak,kmt) + +!-- update scalars + call update_plumerise(coms,coms%nm1,'S') + + call hadvance_plumerise(1,coms%nm1,coms%dt,COMS%WC,COMS%WT,COMS%W,coms%mintime) + +!-- Buoyancy + call buoyancy_plumerise(COMS%NM1, COMS%T, COMS%TE, COMS%QV, COMS%QVENV, COMS%QH, COMS%QI, COMS%QC, COMS%WT, COMS%SCR1) + +!-- Entrainment + call entrainment(coms,COMS%NM1,COMS%W,COMS%WT,COMS%RADIUS,COMS%ALPHA) + +!-- update W + call update_plumerise(coms,coms%nm1,'W') + + call hadvance_plumerise(2,coms%nm1,coms%dt,COMS%WC,COMS%WT,COMS%W,coms%mintime) + + +!-- misc + do k=2,coms%nm1 +! coms%pe esta em kpa - esat do rams esta em mbar = 100 Pa = 0.1 kpa +! es = 0.1*esat (coms%t(k)) !blob saturation vapor pressure, em kPa +! rotina do plumegen calcula em kPa + es = esat_pr (coms%t(k)) !blob saturation vapor pressure, em kPa + coms%qsat(k) = (eps * es) / (coms%pe(k) - es) !blob saturation lwc g/g dry air + coms%est (k) = es + coms%txs (k) = coms%t(k) - coms%te(k) +!sam if(.not.coms%pe(K)>0 .or. .not. coms%T(K)>200) then +!sam 1305 format('(1305) bad input to rho at K=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1305) K,coms%PE(K),coms%T(K) +!sam endif + coms%rho (k) = 3483.8 * coms%pe (k) / coms%t (k) ! air parcel density , g/m**3 + ! no pressure diff with radius + if((abs(coms%wc(k))).gt.wmax) wmax = abs(coms%wc(k)) ! keep wmax largest w + enddo + +! Gravity wave damping using Rayleigh friction layer for W + call damp_grav_wave(2,coms%nm1,deltak,coms%dt,coms%zt,coms%zm,coms%w,coms%t,coms%tt,coms%qv,coms%qh,coms%qi,coms%qc,coms%te,coms%pe,coms%qvenv) +!--- + !- update radius + do k=2,coms%nm1 + coms%radius(k) = coms%rad_p(k) + enddo + !-- try to find the plume top (above surface height) + kk = 1 + DO WHILE (coms%w (kk) .GT. 1.) + kk = kk + 1 + coms%ztop = coms%zm(kk) + !print*,'W=',coms%w (kk) + ENDDO + ! + coms%ztop_(coms%mintime) = coms%ztop + ztopmax = MAX (coms%ztop, ztopmax) + kkmax = MAX (kk , kkmax ) + !print * ,'ztopmax=', coms%mintime,'mn ',coms%ztop_(coms%mintime), ztopmax + + ! + ! if the solution is going to a stationary phase, exit + IF(coms%mintime > 10) THEN + ! if(coms%mintime > 20) then + ! if( abs(coms%ztop_(coms%mintime)-coms%ztop_(coms%mintime-10)) < COMS%DZ ) exit + IF( ABS(coms%ztop_(coms%mintime)-coms%ztop_(coms%mintime-10)) < DELZ_THRESOLD) then + !- determine W parameter to determine the VMD + !do k=2,coms%nm1 + ! W_VMD(k,imm) = coms%w(k) + !enddo + EXIT ! finish the integration + ENDIF + ENDIF + + ! if(ilastprint == coms%mintime) then + ! call printout (izprint,nrectotal) + ! ilastprint = coms%mintime+1 + ! endif + + +ENDDO !do next timestep + +!print * ,' ztopmax=',ztopmax,'m',coms%mintime,'mn ' +!print*,'=======================================================' +! +!the last printout +!if (izprint.ne.0) then +! call printout (izprint,nrectotal) +! close (2) +! close (19) +!endif + +RETURN +END SUBROUTINE MAKEPLUME +!------------------------------------------------------------------------------- +! +SUBROUTINE BURN(COMS, EFLUX, WATER) +! +!- calculates the energy flux and water content at lboundary +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +!real(kind=kind_phys), parameter :: HEAT = 21.E6 !Joules/kg +!real(kind=kind_phys), parameter :: HEAT = 15.5E6 !Joules/kg - cerrado +real(kind=kind_phys), parameter :: HEAT = 19.3E6 !Joules/kg - floresta em Alta Floresta (MT) +real(kind=kind_phys) :: eflux,water +! +! The emission factor for water is 0.5. The water produced, in kg, +! is then fuel mass*0.5 + (moist/100)*mass per square meter. +! The fire burns for DT out of TDUR seconds, the total amount of +! fuel burned is AREA*COMS%BLOAD*(COMS%DT/TDUR) kg. this amount of fuel is +! considered to be spread over area AREA and so the mass burned per +! unit area is COMS%BLOAD*(COMS%DT/TDUR), and the rate is COMS%BLOAD/TDUR. +! +IF (COMS%TIME.GT.COMS%TDUR) THEN !is the burn over? + EFLUX = 0.000001 !prevent a potential divide by zero + WATER = 0. + RETURN +ELSE +! + EFLUX = COMS%HEATING (COMS%MINTIME) ! Watts/m**2 +! WATER = EFLUX * (COMS%DT / HEAT) * (0.5 + COMS%FMOIST) ! kg/m**2 + WATER = EFLUX * (COMS%DT / HEAT) * (0.5 + COMS%FMOIST) /0.55 ! kg/m**2 + WATER = WATER * 1000. ! g/m**2 +! +! print*,'BURN:',coms%time,EFLUX/1.e+9 +ENDIF +! +RETURN +END SUBROUTINE BURN +!------------------------------------------------------------------------------- +! +SUBROUTINE LBOUND (coms) +! +! ********** BOUNDARY CONDITIONS AT ZSURF FOR PLUME AND CLOUD ******** +! +! source of equations: J.S. Turner Buoyancy Effects in Fluids +! Cambridge U.P. 1973 p.172, +! G.A. Briggs Plume Rise, USAtomic Energy Commissio +! TID-25075, 1969, P.28 +! +! fundamentally a point source below ground. at surface, this produces +! a velocity w(1) and temperature T(1) which vary with time. There is +! also a water load which will first saturate, then remainder go into +! QC(1). +! EFLUX = energy flux at ground,watt/m**2 for the last DT +! +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), parameter :: g = 9.80796, r = 287.04, cp = 1004.6, eps = 0.622,tmelt = 273.3 +real(kind=kind_phys), parameter :: tfreeze = 269.3, pi = 3.14159, e1 = 1./3., e2 = 5./3. +real(kind=kind_phys) :: es, esat, eflux, water, pres, c1, c2, f, zv, denscor, xwater !,ESAT_PR +! real(kind=kind_phys), external:: esat_pr! + +! +COMS%QH (1) = COMS%QH (2) !soak up hydrometeors +COMS%QI (1) = COMS%QI (2) +COMS%QC (1) = 0. !no cloud here +! +! + CALL BURN (COMS, EFLUX, WATER) +! +! calculate parameters at boundary from a virtual buoyancy point source +! + PRES = COMS%PE (1) * 1000. !need pressure in N/m**2 + + C1 = 5. / (6. * COMS%ALPHA) !alpha is entrainment constant + + C2 = 0.9 * COMS%ALPHA + + F = EFLUX / (PRES * CP * PI) + + F = G * R * F * COMS%AREA !buoyancy flux + + ZV = C1 * COMS%RSURF !virtual boundary height + + COMS%W (1) = C1 * ( (C2 * F) **E1) / ZV**E1 !boundary velocity + + DENSCOR = C1 * F / G / (C2 * F) **E1 / ZV**E2 !density correction + + COMS%T (1) = COMS%TE (1) / (1. - DENSCOR) !temperature of virtual plume at zsurf + +! + COMS%WC(1) = COMS%W(1) + COMS%VEL_P(1) = 0. + coms%rad_p(1) = coms%rsurf + + !COMS%SC(1) = COMS%SCE(1)+F/1000.*coms%dt ! gas/particle (g/g) + +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! match dw/dz,dt/dz at the boundary. F is conserved. +! + !COMS%WBAR = COMS%W (1) * (1. - 1. / (6. * ZV) ) + !COMS%ADVW = COMS%WBAR * COMS%W (1) / (3. * ZV) + !COMS%ADVT = COMS%WBAR * (5. / (3. * ZV) ) * (DENSCOR / (1. - DENSCOR) ) + !COMS%ADVC = 0. + !COMS%ADVH = 0. + !COMS%ADVI = 0. + !COMS%ADIABAT = - COMS%WBAR * G / CP + COMS%VTH (1) = - 4. + COMS%VTI (1) = - 3. + COMS%TXS (1) = COMS%T (1) - COMS%TE (1) + + COMS%VISC (1) = COMS%VISCOSITY + +!sam if(.not.coms%pe(1)>0 .or. .not. coms%T(1)>200) then +!sam 1306 format('(1306) bad input to rho at 1=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1306) 1,coms%PE(1),coms%T(1) +!sam endif + COMS%RHO (1) = 3483.8 * COMS%PE (1) / COMS%T (1) !air density at level 1, g/m**3 + + XWATER = WATER / max(1e-20, COMS%W (1) * COMS%DT * COMS%RHO (1) ) !firewater mixing ratio + + COMS%QV (1) = XWATER + COMS%QVENV (1) !plus what's already there + + +! COMS%PE esta em kPa - ESAT do RAMS esta em mbar = 100 Pa = 0.1 kPa +! ES = 0.1*ESAT (COMS%T(1)) !blob saturation vapor pressure, em kPa +! rotina do plumegen ja calcula em kPa + ES = ESAT_PR (COMS%T(1)) !blob saturation vapor pressure, em kPa + + COMS%EST (1) = ES + COMS%QSAT (1) = (EPS * ES) / max(1e-20, COMS%PE (1) - ES) !blob saturation lwc g/g dry air + + IF (COMS%QV (1) .gt. COMS%QSAT (1) ) THEN + COMS%QC (1) = COMS%QV (1) - COMS%QSAT (1) + COMS%QC (1) !remainder goes into cloud drops + COMS%QV (1) = COMS%QSAT (1) + ENDIF +! + CALL WATERBAL (COMS) +! +RETURN +END SUBROUTINE LBOUND +!------------------------------------------------------------------------------- +! +SUBROUTINE INITIAL (coms,kmt) +! +! ************* SETS UP INITIAL CONDITIONS FOR THE PROBLEM ************ +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), parameter :: tfreeze = 269.3 +integer :: isub, k, n1, n2, n3, lbuoy, itmp, isubm1 ,kmt +real(kind=kind_phys) :: xn1, xi, es, esat!,ESAT_PR +! +COMS%N=kmt +! initialize temperature structure,to the end of equal spaced sounding, + do k = 1, COMS%N + COMS%TXS (k) = 0.0 + COMS%W (k) = 0.0 + COMS%T (k) = COMS%TE(k) !blob set to environment + COMS%WC(k) = 0.0 + COMS%WT(k) = 0.0 + COMS%QV(k) = COMS%QVENV (k) !blob set to environment + COMS%VTH(k) = 0. !initial rain velocity = 0 + COMS%VTI(k) = 0. !initial ice velocity = 0 + COMS%QH(k) = 0. !no rain + COMS%QI(k) = 0. !no ice + COMS%QC(k) = 0. !no cloud drops +! COMS%PE esta em kPa - ESAT do RAMS esta em mbar = 100 Pa = 0.1 kPa +! ES = 0.1*ESAT (COMS%T(k)) !blob saturation vapor pressure, em kPa +! rotina do plumegen calcula em kPa + ES = ESAT_PR (COMS%T(k)) !blob saturation vapor pressure, em kPa + COMS%EST (k) = ES + COMS%QSAT (k) = (.622 * ES) / (COMS%PE (k) - ES) !saturation lwc g/g +!sam if(.not.coms%pe(k)>0 .or. .not. coms%T(k)>200) then +!sam 1307 format('(1307) bad input to rho at k=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1307) k,coms%PE(k),coms%T(k) +!sam endif + COMS%RHO (k) = 3483.8 * COMS%PE (k) / COMS%T (k) !dry air density g/m**3 + COMS%VEL_P(k) = 0. + coms%rad_p(k) = 0. + enddo + +! Initialize the entrainment radius, Turner-style plume + coms%radius(1) = coms%rsurf + do k=2,COMS%N + coms%radius(k) = coms%radius(k-1)+(6./5.)*coms%alpha*(coms%zt(k)-coms%zt(k-1)) + enddo +! Initialize the entrainment radius, Turner-style plume + coms%radius(1) = coms%rsurf + coms%rad_p(1) = coms%rsurf + DO k=2,COMS%N + coms%radius(k) = coms%radius(k-1)+(6./5.)*coms%alpha*(coms%zt(k)-coms%zt(k-1)) + coms%rad_p(k) = coms%radius(k) + ENDDO + +! Initialize the viscosity + COMS%VISC (1) = COMS%VISCOSITY + do k=2,COMS%N + !COMS%VISC (k) = COMS%VISCOSITY!max(1.e-3,coms%visc(k-1) - 1.* COMS%VISCOSITY/float(nkp)) + COMS%VISC (k) = max(1.e-3,coms%visc(k-1) - 1.* COMS%VISCOSITY/float(nkp)) + enddo +!-- Initialize gas/concentration + !DO k =10,20 + ! COMS%SC(k) = 20. + !ENDDO + !stop 333 + + CALL LBOUND(COMS) + +RETURN +END SUBROUTINE INITIAL +!------------------------------------------------------------------------------- +! +subroutine damp_grav_wave(ifrom,nm1,deltak,dt,zt,zm,w,t,tt,qv,qh,qi,qc,te,pe,qvenv) +implicit none +integer nm1,ifrom,deltak +real(kind=kind_phys) dt +real(kind=kind_phys), dimension(nm1) :: w,t,tt,qv,qh,qi,qc,te,pe,qvenv,dummy,zt,zm + +if(ifrom==1) then + call friction(ifrom,nm1,deltak,dt,zt,zm,t,tt ,te) +!call friction(ifrom,nm1,dt,zt,zm,qv,coms%qvt,qvenv) + return +endif + +dummy(:) = 0. +if(ifrom==2) call friction(ifrom,nm1,deltak,dt,zt,zm,w,dummy ,dummy) +!call friction(ifrom,nm1,dt,zt,zm,qi,coms%qit ,dummy) +!call friction(ifrom,nm1,dt,zt,zm,qh,coms%qht ,dummy) +!call friction(ifrom,nm1,dt,zt,zm,qc,coms%qct ,dummy) +return +end subroutine damp_grav_wave +!------------------------------------------------------------------------------- +! +subroutine friction(ifrom,nm1,deltak,dt,zt,zm,var1,vart,var2) +implicit none +real(kind=kind_phys), dimension(nm1) :: var1,var2,vart,zt,zm +integer k,nfpt,kf,nm1,ifrom,deltak +real(kind=kind_phys) zmkf,ztop,distim,c1,c2,dt + +!nfpt=50 +!kf = nm1 - nfpt +!kf = nm1 - int(deltak/2) + kf = nm1 - int(deltak) + +zmkf = zm(kf) !old: float(kf )*coms%dz +ztop = zm(nm1) +!distim = min(4.*dt,200.) +!distim = 60. + distim = min(3.*dt,60.) + +c1 = 1. / (distim * (ztop - zmkf)) +c2 = dt * c1 + +if(ifrom == 1) then + do k = nm1,2,-1 + if (zt(k) .le. zmkf) cycle + vart(k) = vart(k) + c1 * (zt(k) - zmkf)*(var2(k) - var1(k)) + enddo +elseif(ifrom == 2) then + do k = nm1,2,-1 + if (zt(k) .le. zmkf) cycle + var1(k) = var1(k) + c2 * (zt(k) - zmkf)*(var2(k) - var1(k)) + enddo +endif +return +end subroutine friction +!------------------------------------------------------------------------------- +! +subroutine vel_advectc_plumerise(m1,wc,wt,rho,dzm) + +implicit none +integer :: k,m1 +real(kind=kind_phys), dimension(m1) :: wc,wt,flxw,dzm,rho +real(kind=kind_phys), dimension(m1) :: dn0 ! var local +real(kind=kind_phys) :: c1z + +!dzm(:)= 1./coms%dz + +dn0(1:m1)=rho(1:m1)*1.e-3 ! converte de cgs para mks + +flxw(1) = wc(1) * dn0(1) + +do k = 2,m1-1 + flxw(k) = wc(k) * .5 * (dn0(k) + dn0(k+1)) +enddo + +! Compute advection contribution to W tendency + +c1z = .5 + +do k = 2,m1-2 + + wt(k) = wt(k) & + + c1z * dzm(k) / (dn0(k) + dn0(k+1)) * ( & + (flxw(k) + flxw(k-1)) * (wc(k) + wc(k-1)) & + - (flxw(k) + flxw(k+1)) * (wc(k) + wc(k+1)) & + + (flxw(k+1) - flxw(k-1)) * 2.* wc(k) ) + +enddo + +return +end subroutine vel_advectc_plumerise +!------------------------------------------------------------------------------- +! +subroutine hadvance_plumerise(iac,m1,dt,wc,wt,wp,mintime) + +implicit none +integer :: k,iac +integer :: m1,mintime +real(kind=kind_phys), dimension(m1) :: dummy, wc,wt,wp +real(kind=kind_phys) eps,dt +! It is here that the Asselin filter is applied. For the velocities +! and pressure, this must be done in two stages, the first when +! IAC=1 and the second when IAC=2. + + +eps = .2 +if(mintime == 1) eps=0.5 + +! For both IAC=1 and IAC=2, call PREDICT for U, V, W, and P. +! +call predict_plumerise(m1,wc,wp,wt,dummy,iac,2.*dt,eps) +!print*,'mintime',mintime,eps +!do k=1,m1 +! print*,'W-HAD',k,wc(k),wp(k),wt(k) +!enddo +return +end subroutine hadvance_plumerise +!------------------------------------------------------------------------------- +! +subroutine predict_plumerise(npts,ac,ap,fa,af,iac,dtlp,epsu) +implicit none +integer :: npts,iac,m +real(kind=kind_phys) :: epsu,dtlp +real(kind=kind_phys), dimension(*) :: ac,ap,fa,af + +! For IAC=3, this routine moves the arrays AC and AP forward by +! 1 time level by adding in the prescribed tendency. It also +! applies the Asselin filter given by: + +! {AC} = AC + EPS * (AP - 2 * AC + AF) + +! where AP,AC,AF are the past, current and future time levels of A. +! All IAC=1 does is to perform the {AC} calculation without the AF +! term present. IAC=2 completes the calculation of {AC} by adding +! the AF term only, and advances AC by filling it with input AP +! values which were already updated in ACOUSTC. +! + +if (iac .eq. 1) then + do m = 1,npts + ac(m) = ac(m) + epsu * (ap(m) - 2. * ac(m)) + enddo + return +elseif (iac .eq. 2) then + do m = 1,npts + af(m) = ap(m) + ap(m) = ac(m) + epsu * af(m) + enddo +!elseif (iac .eq. 3) then +! do m = 1,npts +! af(m) = ap(m) + dtlp * fa(m) +! enddo +! if (ngrid .eq. 1 .and. ipara .eq. 0) call cyclic(nzp,nxp,nyp,af,'T') +! do m = 1,npts +! ap(m) = ac(m) + epsu * (ap(m) - 2. * ac(m) + af(m)) +! enddo +endif + +do m = 1,npts + ac(m) = af(m) +enddo +return +end subroutine predict_plumerise +!------------------------------------------------------------------------------- +! +subroutine buoyancy_plumerise(m1, T, TE, QV, QVENV, QH, QI, QC, WT, scr1) +implicit none +integer :: k,m1 +real(kind=kind_phys), parameter :: g = 9.8, eps = 0.622, gama = 0.5 ! mass virtual coeff. +real(kind=kind_phys), dimension(m1) :: T, TE, QV, QVENV, QH, QI, QC, WT, scr1 +real(kind=kind_phys) :: TV,TVE,QWTOTL,umgamai +real(kind=kind_phys), parameter :: mu = 0.15 + +!- orig +umgamai = 1./(1.+gama) ! compensa a falta do termo de aceleracao associado `as + ! das pertubacoes nao-hidrostaticas no campo de pressao + +!- new ! Siesbema et al, 2004 +!umgamai = 1./(1.-2.*mu) + +do k = 2,m1-1 + + TV = T(k) * (1. + (QV(k) /EPS))/(1. + QV(k) ) !blob virtual temp. + TVE = TE(k) * (1. + (QVENV(k)/EPS))/(1. + QVENV(k)) !and environment + + QWTOTL = QH(k) + QI(k) + QC(k) ! QWTOTL*G is drag +!- orig + !scr1(k)= G*( umgamai*( TV - TVE) / TVE - QWTOTL) + scr1(k)= G* umgamai*( (TV - TVE) / TVE - QWTOTL) + + !if(k .lt. 10)print*,'BT',k,TV,TVE,TVE,QWTOTL +enddo + +do k = 2,m1-2 + wt(k) = wt(k)+0.5*(scr1(k)+scr1(k+1)) +! print*,'W-BUO',k,wt(k),scr1(k),scr1(k+1) +enddo + +end subroutine buoyancy_plumerise +!------------------------------------------------------------------------------- +! +subroutine ENTRAINMENT(coms,m1,w,wt,radius,ALPHA) +implicit none +type(plumegen_coms), pointer :: coms +integer :: k,m1 +real(kind=kind_phys), dimension(m1) :: w,wt,radius +REAL(kind=kind_phys) DMDTM,WBAR,RADIUS_BAR,umgamai,DYN_ENTR,ALPHA +real(kind=kind_phys), parameter :: mu = 0.15 ,gama = 0.5 ! mass virtual coeff. + +!- new - Siesbema et al, 2004 +!umgamai = 1./(1.-2.*mu) + +!- orig +!umgamai = 1 +umgamai = 1./(1.+gama) ! compensa a falta do termo de aceleracao associado `as + ! das pertubacoes nao-hidrostaticas no campo de pressao + +! +!-- ALPHA/RADIUS(COMS%L) = (1/M)DM/COMS%DZ (W 14a) + do k=2,m1-1 + +!-- for W: WBAR is only W(k) +! WBAR=0.5*(W(k)+W(k-1)) + WBAR=W(k) + RADIUS_BAR = 0.5*(RADIUS(k) + RADIUS(k-1)) +! orig + !DMDTM = 2. * ALPHA * ABS (WBAR) / RADIUS_BAR != (1/M)DM/COMS%DT + DMDTM = umgamai * 2. * ALPHA * ABS (WBAR) / RADIUS_BAR != (1/M)DM/COMS%DT + +!-- DMDTM*W(COMS%L) entrainment, + wt(k) = wt(k) - DMDTM*ABS (WBAR) + !print*,'W-ENTR=',k,w(k),- DMDTM*ABS (WBAR) + + !if(COMS%VEL_P (k) - COMS%VEL_E (k) > 0.) cycle + + !- dynamic entrainment + DYN_ENTR = (2./3.1416)*0.5*ABS (COMS%VEL_P(k)-COMS%VEL_E(k)+COMS%VEL_P(k-1)-COMS%VEL_E(k-1)) /RADIUS_BAR + + wt(k) = wt(k) - DYN_ENTR*ABS (WBAR) + + !- entraiment acceleration for output only + !dwdt_entr(k) = - DMDTM*ABS (WBAR)- DYN_ENTR*ABS (WBAR) + enddo +end subroutine ENTRAINMENT +!------------------------------------------------------------------------------- +! +subroutine scl_advectc_plumerise(coms,varn,mzp) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer :: mzp +character(len=*) :: varn +real(kind=kind_phys) :: dtlto2 +integer :: k + +! wp => w +!- Advect scalars + dtlto2 = .5 * coms%dt +! coms%vt3dc(1) = (coms%w(1) + coms%wc(1)) * dtlto2 * coms%dne(1) + coms%vt3dc(1) = (coms%w(1) + coms%wc(1)) * dtlto2 * coms%rho(1)*1.e-3!converte de CGS p/ MKS + coms%vt3df(1) = .5 * (coms%w(1) + coms%wc(1)) * dtlto2 * coms%dzm(1) + + do k = 2,mzp +! coms%vt3dc(k) = (coms%w(k) + coms%wc(k)) * dtlto2 *.5 * (coms%dne(k) + coms%dne(k+1)) + coms%vt3dc(k) = (coms%w(k) + coms%wc(k)) * dtlto2 *.5 * (coms%rho(k) + coms%rho(k+1))*1.e-3 + coms%vt3df(k) = (coms%w(k) + coms%wc(k)) * dtlto2 *.5 * coms%dzm(k) + !print*,'coms%vt3df-coms%vt3dc',k,coms%vt3dc(k),coms%vt3df(k) + enddo + + +!-srf-24082005 +! do k = 1,mzp-1 + do k = 1,mzp + coms%vctr1(k) = (coms%zt(k+1) - coms%zm(k)) * coms%dzm(k) + coms%vctr2(k) = (coms%zm(k) - coms%zt(k)) * coms%dzm(k) +! coms%vt3dk(k) = coms%dzt(k) / coms%dne(k) + coms%vt3dk(k) = coms%dzt(k) /(coms%rho(k)*1.e-3) + !print*,'Coms%Vt3dk',k,coms%dzt(k) , coms%dne(k) + enddo + +! scalarp => scalar_tab(coms%n,ngrid)%var_p +! scalart => scalar_tab(coms%n,ngrid)%var_t + +!- temp advection tendency (COMS%TT) + coms%scr1=COMS%T + call fa_zc_plumerise(mzp & + ,COMS%T ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%T,coms%scr1(1),COMS%TT,coms%dt) + +!- water vapor advection tendency (COMS%QVT) + coms%scr1=COMS%QV + call fa_zc_plumerise(mzp & + ,COMS%QV ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QV,coms%scr1(1),COMS%QVT,coms%dt) + +!- liquid advection tendency (COMS%QCT) + coms%scr1=COMS%QC + call fa_zc_plumerise(mzp & + ,COMS%QC ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QC,coms%scr1(1),COMS%QCT,coms%dt) + +!- ice advection tendency (COMS%QIT) + coms%scr1=COMS%QI + call fa_zc_plumerise(mzp & + ,COMS%QI ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QI,coms%scr1(1),COMS%QIT,coms%dt) + +!- hail/rain advection tendency (COMS%QHT) +! if(ak1 > 0. .or. ak2 > 0.) then + + coms%scr1=COMS%QH + call fa_zc_plumerise(mzp & + ,COMS%QH ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QH,coms%scr1(1),COMS%QHT,coms%dt) +! endif + !- horizontal wind advection tendency (COMS%VEL_T) + coms%scr1=COMS%VEL_P + call fa_zc_plumerise(mzp & + ,COMS%VEL_P ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%VEL_P,coms%scr1(1),COMS%VEL_T,coms%dt) + + !- vertical radius transport + + coms%scr1=coms%rad_p + call fa_zc_plumerise(mzp & + ,coms%rad_p ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,coms%rad_p,coms%scr1(1),coms%rad_t,coms%dt) + + + return +! +!- gas/particle advection tendency (COMS%SCT) +! if(varn == 'SC')return + coms%scr1=COMS%SC + call fa_zc_plumerise(mzp & + ,COMS%SC ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%SC,coms%scr1(1),COMS%SCT,coms%dt) + + +return +end subroutine scl_advectc_plumerise +!------------------------------------------------------------------------------- +! +subroutine fa_zc_plumerise(m1,scp,scr1,vt3dc,vt3df,vt3dg,vt3dk,vctr1,vctr2) + +implicit none +integer :: m1,k +real(kind=kind_phys) :: dfact +real(kind=kind_phys), dimension(m1) :: scp,scr1,vt3dc,vt3df,vt3dg,vt3dk +real(kind=kind_phys), dimension(m1) :: vctr1,vctr2 + +dfact = .5 + +! Compute scalar flux VT3DG + do k = 1,m1-1 + vt3dg(k) = vt3dc(k) & + * (vctr1(k) * scr1(k) & + + vctr2(k) * scr1(k+1) & + + vt3df(k) * (scr1(k) - scr1(k+1))) + enddo + +! Modify fluxes to retain positive-definiteness on scalar quantities. +! If a flux will remove 1/2 quantity during a timestep, +! reduce to first order flux. This will remain positive-definite +! under the assumption that ABS(CFL(i)) + ABS(CFL(i-1)) < 1.0 if +! both fluxes are evacuating the box. + +do k = 1,m1-1 + if (vt3dc(k) .gt. 0.) then + if (vt3dg(k) * vt3dk(k) .gt. dfact * scr1(k)) then + vt3dg(k) = vt3dc(k) * scr1(k) + endif + elseif (vt3dc(k) .lt. 0.) then + if (-vt3dg(k) * vt3dk(k+1) .gt. dfact * scr1(k+1)) then + vt3dg(k) = vt3dc(k) * scr1(k+1) + endif + endif + +enddo + +! Compute flux divergence +do k = 2,m1-1 + scr1(k) = scr1(k) & + + vt3dk(k) * ( vt3dg(k-1) - vt3dg(k) & + + scp (k) * ( vt3dc(k) - vt3dc(k-1))) +enddo +return +end subroutine fa_zc_plumerise +!------------------------------------------------------------------------------- +! +subroutine advtndc_plumerise(m1,scp,sca,sct,dtl) +implicit none +integer :: m1,k +real(kind=kind_phys) :: dtl,dtli +real(kind=kind_phys), dimension(m1) :: scp,sca,sct + +dtli = 1. / dtl +do k = 2,m1-1 + sct(k) = sct(k) + (sca(k)-scp(k)) * dtli +enddo +return +end subroutine advtndc_plumerise +!------------------------------------------------------------------------------- +! +subroutine tend0_plumerise(coms) +implicit none +type(plumegen_coms), pointer :: coms + coms%wt(1:coms%nm1) = 0. + coms%tt(1:coms%nm1) = 0. +coms%qvt(1:coms%nm1) = 0. +coms%qct(1:coms%nm1) = 0. +coms%qht(1:coms%nm1) = 0. +coms%qit(1:coms%nm1) = 0. +coms%vel_t(1:coms%nm1) = 0. +coms%rad_t(1:coms%nm1) = 0. +!coms%sct(1:coms%nm1) = 0. +end subroutine tend0_plumerise + +! **************************************************************** + +subroutine scl_misc(coms,m1) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), parameter :: g = 9.81, cp=1004. +integer m1,k +real(kind=kind_phys) dmdtm + + do k=2,m1-1 + COMS%WBAR = 0.5*(COMS%W(k)+COMS%W(k-1)) +!-- dry adiabat + COMS%ADIABAT = - COMS%WBAR * G / CP +! +!-- entrainment + DMDTM = 2. * COMS%ALPHA * ABS (COMS%WBAR) / COMS%RADIUS (k) != (1/M)DM/COMS%DT + +!-- tendency temperature = adv + adiab + entrainment + COMS%TT(k) = COMS%TT(K) + COMS%ADIABAT - DMDTM * ( COMS%T (k) - COMS%TE (k) ) + +!-- tendency water vapor = adv + entrainment + COMS%QVT(K) = COMS%QVT(K) - DMDTM * ( COMS%QV (k) - COMS%QVENV (k) ) + + COMS%QCT(K) = COMS%QCT(K) - DMDTM * ( COMS%QC (k) ) + COMS%QHT(K) = COMS%QHT(K) - DMDTM * ( COMS%QH (k) ) + COMS%QIT(K) = COMS%QIT(K) - DMDTM * ( COMS%QI (k) ) + + !-- tendency horizontal speed = adv + entrainment + COMS%VEL_T(K) = COMS%VEL_T(K) - DMDTM * ( COMS%VEL_P (k) - COMS%VEL_E (k) ) + + !-- tendency horizontal speed = adv + entrainment + coms%rad_t(K) = coms%rad_t(K) + 0.5*DMDTM*(6./5.)*COMS%RADIUS (k) +!-- tendency gas/particle = adv + entrainment +! COMS%SCT(K) = COMS%SCT(K) - DMDTM * ( COMS%SC (k) - COMS%SCE (k) ) + +enddo +end subroutine scl_misc +! **************************************************************** + + SUBROUTINE scl_dyn_entrain(m1,nkp,wbar,w,adiabat,alpha,radius,tt,t,te,qvt,qv,qvenv,qct,qc,qht,qh,qit,qi,& + vel_e,vel_p,vel_t,rad_p,rad_t) + implicit none + + INTEGER , INTENT(IN) :: m1 + + ! plumegen_coms + INTEGER , INTENT(IN) :: nkp + REAL(kind=kind_phys) , INTENT(INOUT) :: wbar + REAL(kind=kind_phys) , INTENT(IN) :: w(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: adiabat + REAL(kind=kind_phys) , INTENT(IN) :: alpha + REAL(kind=kind_phys) , INTENT(IN) :: radius(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: tt(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: t(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: te(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qvt(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qv(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qvenv(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qct(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qc(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qht(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qh(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qit(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qi(nkp) + + REAL(kind=kind_phys) , INTENT(IN) :: vel_e(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: vel_p(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: vel_t(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: rad_T(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: rad_p(nkp) + + real(kind=kind_phys), parameter :: g = 9.81, cp=1004., pi=3.1416 + + integer k + real(kind=kind_phys) dmdtm + + DO k=2,m1-1 + ! + !-- tendency horizontal radius from dyn entrainment + !rad_t(K) = rad_t(K) + (vel_e(k)-vel_p(k)) /pi + rad_t(K) = rad_t(K) + ABS((vel_e(k)-vel_p(k)))/pi + + !-- entrainment + !DMDTM = (2./3.1416) * (VEL_E (k) - VEL_P (k)) / RADIUS (k) + DMDTM = (2./3.1416) * ABS(VEL_E (k) - VEL_P (k)) / RADIUS (k) + + !-- tendency horizontal speed from dyn entrainment + VEL_T(K) = VEL_T(K) - DMDTM * ( VEL_P (k) - VEL_E (k) ) + + ! if(VEL_P (k) - VEL_E (k) > 0.) cycle + + !-- tendency temperature from dyn entrainment + TT(k) = TT(K) - DMDTM * ( T (k) - TE (k) ) + + !-- tendency water vapor from dyn entrainment + QVT(K) = QVT(K) - DMDTM * ( QV (k) - QVENV (k) ) + + QCT(K) = QCT(K) - DMDTM * ( QC (k) ) + QHT(K) = QHT(K) - DMDTM * ( QH (k) ) + QIT(K) = QIT(K) - DMDTM * ( QI (k) ) + + !-- tendency gas/particle from dyn entrainment + ! COMS%SCT(K) = COMS%SCT(K) - DMDTM * ( SC (k) - COMS%SCE (k) ) + + ENDDO + END SUBROUTINE scl_dyn_entrain + +! **************************************************************** + +subroutine visc_W(coms,m1,deltak,kmt) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer m1,k,deltak,kmt,m2 +real(kind=kind_phys) dz1t,dz1m,dz2t,dz2m,d2wdz,d2tdz ,d2qvdz ,d2qhdz ,d2qcdz ,d2qidz ,d2scdz, & + d2vel_pdz,d2rad_dz +!sam real(kind=kind_phys) :: old_tt +logical, save, volatile :: printed = .false. + + +!srf--- 17/08/2005 +!m2=min(m1+deltak,kmt) +m2=min(m1,kmt) + +!do k=2,m1-1 +do k=2,m2-1 + DZ1T = 0.5*(COMS%ZT(K+1)-COMS%ZT(K-1)) + DZ2T = COMS%VISC (k) / (DZ1T * DZ1T) + DZ1M = 0.5*(COMS%ZM(K+1)-COMS%ZM(K-1)) + DZ2M = COMS%VISC (k) / (DZ1M * DZ1M) + D2WDZ = (COMS%W (k + 1) - 2 * COMS%W (k) + COMS%W (k - 1) ) * DZ2M + D2TDZ = (COMS%T (k + 1) - 2 * COMS%T (k) + COMS%T (k - 1) ) * DZ2T + D2QVDZ = (COMS%QV (k + 1) - 2 * COMS%QV (k) + COMS%QV (k - 1) ) * DZ2T + D2QHDZ = (COMS%QH (k + 1) - 2 * COMS%QH (k) + COMS%QH (k - 1) ) * DZ2T + D2QCDZ = (COMS%QC (k + 1) - 2 * COMS%QC (k) + COMS%QC (k - 1) ) * DZ2T + D2QIDZ = (COMS%QI (k + 1) - 2 * COMS%QI (k) + COMS%QI (k - 1) ) * DZ2T + !D2SCDZ = (COMS%SC (k + 1) - 2 * COMS%SC (k) + COMS%SC (k - 1) ) * DZ2T + d2vel_pdz=(coms%vel_p (k + 1) - 2 * coms%vel_p (k) + coms%vel_p (k - 1) ) * DZ2T + d2rad_dz =(coms%rad_p (k + 1) - 2 * coms%rad_p (k) + coms%rad_p (k - 1) ) * DZ2T + + COMS%WT(k) = COMS%WT(k) + D2WDZ +!sam old_tt=coms%tt(k) + COMS%TT(k) = COMS%TT(k) + D2TDZ +!sam if(.not. coms%tt(k)>-10 .and. .not. printed) then +!sam 1924 format("(1924) visc_W Bad TT at k=",I0," TT=",F12.5," old_TT=",F12.5," d2tdz=",F12.5," visc=",F12.5) +!sam 1925 format("(1925) T = ",F12.5,",",F12.5,",",F12.5," ZT=",F12.5,",",F12.5) +!sam write(0,1924) k, COMS%TT(k), old_TT, d2tdz, coms%visc(k) +!sam write(0,1925) coms%T(k-1),coms%T(k),coms%T(k+1),coms%ZT(k-1),coms%ZT(k+1) +!sam printed = .true. +!sam endif + COMS%QVT(k) = COMS%QVT(k) + D2QVDZ + COMS%QCT(k) = COMS%QCT(k) + D2QCDZ + COMS%QHT(k) = COMS%QHT(k) + D2QHDZ + COMS%QIT(k) = COMS%QIT(k) + D2QIDZ + coms%vel_t(k) = coms%vel_t(k) + d2vel_pdz + coms%rad_t(k) = coms%rad_t(k) + d2rad_dz + !COMS%SCT(k) = COMS%SCT(k) + D2SCDZ + !print*,'W-COMS%VISC=',k,D2WDZ +enddo + +end subroutine visc_W + +! **************************************************************** + +subroutine update_plumerise(coms,m1,varn) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer m1,k +character(len=*) :: varn +!sam real(kind_phys) :: old_t + +if(varn == 'W') then + + do k=2,m1-1 + COMS%W(k) = COMS%W(k) + COMS%WT(k) * COMS%DT + enddo + return + +else +do k=2,m1-1 +!sam old_t = coms%t(k) + COMS%T(k) = COMS%T(k) + COMS%TT(k) * COMS%DT +!sam if(.not. coms%t(k)>200) then +!sam 1921 format("(1921) update_plumerise Bad T at k=",I0," T=",F12.5," old_T=",F12.5," TT=",F12.5," DT=",F12.5) +!sam write(0,1921) k, COMS%T(k), old_T, coms%tt(k), coms%dt +!sam endif + + COMS%QV(k) = COMS%QV(k) + COMS%QVT(k) * COMS%DT + + COMS%QC(k) = COMS%QC(k) + COMS%QCT(k) * COMS%DT !cloud drops travel with air + COMS%QH(k) = COMS%QH(k) + COMS%QHT(k) * COMS%DT + COMS%QI(k) = COMS%QI(k) + COMS%QIT(k) * COMS%DT +! COMS%SC(k) = COMS%SC(k) + COMS%SCT(k) * COMS%DT + +!srf---18jun2005 + COMS%QV(k) = max(0., COMS%QV(k)) + COMS%QC(k) = max(0., COMS%QC(k)) + COMS%QH(k) = max(0., COMS%QH(k)) + COMS%QI(k) = max(0., COMS%QI(k)) + + COMS%VEL_P(k) = COMS%VEL_P(k) + COMS%VEL_T(k) * COMS%DT + coms%rad_p(k) = coms%rad_p(k) + coms%rad_t(k) * COMS%DT +! COMS%SC(k) = max(0., COMS%SC(k)) + + enddo +endif +end subroutine update_plumerise +!------------------------------------------------------------------------------- +! +subroutine fallpart(coms,m1) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer m1,k +real(kind=kind_phys) vtc, dfhz,dfiz,dz1 +!srf================================== +! verificar se o gradiente esta correto +! +!srf================================== +! +! XNO=1.E7 [m**-4] median volume diameter raindrop,Kessler +! VC = 38.3/(XNO**.125), median volume fallspeed eqn., Kessler +! for ice, see (OT18), use F0=0.75 per argument there. coms%rho*q +! values are in g/m**3, velocities in m/s + +real(kind=kind_phys), PARAMETER :: VCONST = 5.107387, EPS = 0.622, F0 = 0.75 +real(kind=kind_phys), PARAMETER :: G = 9.81, CP = 1004. +! +do k=2,m1-1 +!sam if(.not. coms%rho(k)>1e-20) then +!sam 33 format('(33) Bad density at k=',I0,' rho=',F12.5,' T=',F12.5,' PE=',F12.5,' test=',I0) +!sam write(0,33) k,coms%rho(k),coms%T(k),coms%PE(k),coms%testval +!sam endif + VTC = VCONST * COMS%RHO (k) **.125 ! median volume fallspeed (KTable4) + +! hydrometeor assembly velocity calculations (K Table4) +! COMS%VTH(k)=-VTC*COMS%QH(k)**.125 !median volume fallspeed, water + COMS%VTH (k) = - 4. !small variation with coms%qh + + COMS%VHREL = COMS%W (k) + COMS%VTH (k) !relative to surrounding cloud + +! rain ventilation coefficient for evaporation + COMS%CVH(k) = 1.6 + 0.57E-3 * (ABS (COMS%VHREL) ) **1.5 +! +! COMS%VTI(k)=-VTC*F0*COMS%QI(k)**.125 !median volume fallspeed,ice + COMS%VTI (k) = - 3. !small variation with coms%qi + + COMS%VIREL = COMS%W (k) + COMS%VTI (k) !relative to surrounding cloud +! +! ice ventilation coefficient for sublimation + COMS%CVI(k) = 1.6 + 0.57E-3 * (ABS (COMS%VIREL) ) **1.5 / F0 +! +! + IF (COMS%VHREL.GE.0.0) THEN + DFHZ=COMS%QH(k)*(COMS%RHO(k )*COMS%VTH(k )-COMS%RHO(k-1)*COMS%VTH(k-1))/COMS%RHO(k-1) + ELSE + DFHZ=COMS%QH(k)*(COMS%RHO(k+1)*COMS%VTH(k+1)-COMS%RHO(k )*COMS%VTH(k ))/COMS%RHO(k) + ENDIF + ! + ! + IF (COMS%VIREL.GE.0.0) THEN + DFIZ=COMS%QI(k)*(COMS%RHO(k )*COMS%VTI(k )-COMS%RHO(k-1)*COMS%VTI(k-1))/COMS%RHO(k-1) + ELSE + DFIZ=COMS%QI(k)*(COMS%RHO(k+1)*COMS%VTI(k+1)-COMS%RHO(k )*COMS%VTI(k ))/COMS%RHO(k) + ENDIF + + DZ1=COMS%ZM(K)-COMS%ZM(K-1) + + coms%qht(k) = coms%qht(k) - DFHZ / DZ1 !hydrometeors don't + coms%qit(k) = coms%qit(k) - DFIZ / DZ1 !nor does ice? hail, what about + +enddo +end subroutine fallpart + +! ********************************************************************* +SUBROUTINE WATERBAL(coms) +implicit none +type(plumegen_coms), pointer :: coms + +!use module_zero_plumegen_coms +! + +IF (COMS%QC (COMS%L) .LE.1.0E-10) COMS%QC (COMS%L) = 0. !DEFEAT UNDERFLOW PROBLEM +IF (COMS%QH (COMS%L) .LE.1.0E-10) COMS%QH (COMS%L) = 0. +IF (COMS%QI (COMS%L) .LE.1.0E-10) COMS%QI (COMS%L) = 0. +! +CALL EVAPORATE(COMS) !vapor to cloud,cloud to vapor +! +CALL SUBLIMATE(COMS) !vapor to ice +! +CALL GLACIATE(COMS) !rain to ice + +CALL MELT(COMS) !ice to rain +! +!if(ak1 > 0. .or. ak2 > 0.) & +CALL CONVERT(COMS) !(auto)conversion and accretion +!CALL CONVERT2 () !(auto)conversion and accretion +! + +RETURN +END SUBROUTINE WATERBAL +! ********************************************************************* +SUBROUTINE EVAPORATE(coms) +! +!- evaporates cloud,rain and ice to saturation +! +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +! +! XNO=10.0E06 +! HERC = 1.93*1.E-6*XN035 !evaporation constant +! +real(kind=kind_phys), PARAMETER :: HERC = 5.44E-4, CP = 1.004, HEATCOND = 2.5E3 +real(kind=kind_phys), PARAMETER :: HEATSUBL = 2834., TMELT = 273., TFREEZE = 269.3 + +real(kind=kind_phys), PARAMETER :: FRC = HEATCOND / CP, SRC = HEATSUBL / CP + +real(kind=kind_phys) :: evhdt, evidt, evrate, evap, sd, quant, dividend, divisor, devidt + +! +! +SD = COMS%QSAT (COMS%L) - COMS%QV (COMS%L) !vapor deficit +IF (SD.EQ.0.0) RETURN +!IF (abs(SD).lt.1.e-7) RETURN + + +EVHDT = 0. +EVIDT = 0. +!evrate =0.; evap=0.; sd=0.0; quant=0.0; dividend=0.0; divisor=0.0; devidt=0.0 + +EVRATE = ABS (COMS%WBAR * COMS%DQSDZ) !evaporation rate (Kessler 8.32) +EVAP = EVRATE * COMS%DT !what we can get in DT + + +IF (SD.LE.0.0) THEN ! condense. SD is negative + + IF (EVAP.GE.ABS (SD) ) THEN !we get it all + + COMS%QC (COMS%L) = COMS%QC (COMS%L) - SD !deficit,remember? + COMS%QV (COMS%L) = COMS%QSAT(COMS%L) !set the vapor to saturation + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC !heat gained through condensation + !per gram of dry air + RETURN + + ELSE + + COMS%QC (COMS%L) = COMS%QC (COMS%L) + EVAP !get what we can in DT + COMS%QV (COMS%L) = COMS%QV (COMS%L) - EVAP !remove it from the vapor + COMS%T (COMS%L) = COMS%T (COMS%L) + EVAP * FRC !get some heat + + RETURN + + ENDIF +! +ELSE !SD is positive, need some water +! +! not saturated. saturate if possible. use everything in order +! cloud, rain, ice. SD is positive + + IF (EVAP.LE.COMS%QC (COMS%L) ) THEN !enough cloud to last DT +! + + IF (SD.LE.EVAP) THEN !enough time to saturate + + COMS%QC (COMS%L) = COMS%QC (COMS%L) - SD !remove cloud + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !saturate + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC !cool the parcel + RETURN !done +! + + ELSE !not enough time + + SD = SD-EVAP !use what there is + COMS%QV (COMS%L) = COMS%QV (COMS%L) + EVAP !add vapor + COMS%T (COMS%L) = COMS%T (COMS%L) - EVAP * FRC !lose heat + COMS%QC (COMS%L) = COMS%QC (COMS%L) - EVAP !lose cloud + !go on to rain. + ENDIF +! + ELSE !not enough cloud to last DT +! + IF (SD.LE.COMS%QC (COMS%L) ) THEN !but there is enough to sat + + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !use it + COMS%QC (COMS%L) = COMS%QC (COMS%L) - SD + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC + RETURN + + ELSE !not enough to sat + SD = SD-COMS%QC (COMS%L) + COMS%QV (COMS%L) = COMS%QV (COMS%L) + COMS%QC (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) - COMS%QC (COMS%L) * FRC + COMS%QC (COMS%L) = 0.0 !all gone + + ENDIF !on to rain + ENDIF !finished with cloud +! +! but still not saturated, so try to use some rain +! this is tricky, because we only have time DT to evaporate. if there +! is enough rain, we can evaporate it for dt. ice can also sublimate +! at the same time. there is a compromise here.....use rain first, then +! ice. saturation may not be possible in one DT time. +! rain evaporation rate (W12),(OT25),(K Table 4). evaporate rain first +! sd is still positive or we wouldn't be here. + + + IF (COMS%QH (COMS%L) .LE.1.E-10) GOTO 33 + +!srf-25082005 +! QUANT = ( COMS%QC (COMS%L) + COMS%QV (COMS%L) - COMS%QSAT (COMS%L) ) * COMS%RHO (COMS%L) !g/m**3 + QUANT = ( COMS%QSAT (COMS%L)- COMS%QC (COMS%L) - COMS%QV (COMS%L) ) * COMS%RHO (COMS%L) !g/m**3 +! + EVHDT = (COMS%DT * HERC * (QUANT) * (COMS%QH (COMS%L) * COMS%RHO (COMS%L) ) **.65) / COMS%RHO (COMS%L) +! rain evaporation in time DT + + IF (EVHDT.LE.COMS%QH (COMS%L) ) THEN !enough rain to last DT + + IF (SD.LE.EVHDT) THEN !enough time to saturate + COMS%QH (COMS%L) = COMS%QH (COMS%L) - SD !remove rain + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !saturate + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC !cool the parcel + + RETURN !done +! + ELSE !not enough time + SD = SD-EVHDT !use what there is + COMS%QV (COMS%L) = COMS%QV (COMS%L) + EVHDT !add vapor + COMS%T (COMS%L) = COMS%T (COMS%L) - EVHDT * FRC !lose heat + COMS%QH (COMS%L) = COMS%QH (COMS%L) - EVHDT !lose rain + + ENDIF !go on to ice. +! + ELSE !not enough rain to last DT +! + IF (SD.LE.COMS%QH (COMS%L) ) THEN !but there is enough to sat + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !use it + COMS%QH (COMS%L) = COMS%QH (COMS%L) - SD + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC + RETURN +! + ELSE !not enough to sat + SD = SD-COMS%QH (COMS%L) + COMS%QV (COMS%L) = COMS%QV (COMS%L) + COMS%QH (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) - COMS%QH (COMS%L) * FRC + COMS%QH (COMS%L) = 0.0 !all gone + + ENDIF !on to ice +! + + ENDIF !finished with rain +! +! +! now for ice +! equation from (OT); correction factors for units applied +! + 33 continue + IF (COMS%QI (COMS%L) .LE.1.E-10) RETURN !no ice there +! + DIVIDEND = ( (1.E6 / COMS%RHO (COMS%L) ) **0.475) * (SD / COMS%QSAT (COMS%L) & + - 1) * (COMS%QI (COMS%L) **0.525) * 1.13 + DIVISOR = 7.E5 + 4.1E6 / (10. * COMS%EST (COMS%L) ) + + DEVIDT = - COMS%CVI(COMS%L) * DIVIDEND / DIVISOR !rate of change + + EVIDT = DEVIDT * COMS%DT !what we could get +! +! logic here is identical to rain. could get fancy and make subroutine +! but duplication of code is easier. God bless the screen editor. +! + + IF (EVIDT.LE.COMS%QI (COMS%L) ) THEN !enough ice to last DT +! + + IF (SD.LE.EVIDT) THEN !enough time to saturate + COMS%QI (COMS%L) = COMS%QI (COMS%L) - SD !remove ice + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !saturate + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * SRC !cool the parcel + + RETURN !done +! + + ELSE !not enough time + + SD = SD-EVIDT !use what there is + COMS%QV (COMS%L) = COMS%QV (COMS%L) + EVIDT !add vapor + COMS%T (COMS%L) = COMS%T (COMS%L) - EVIDT * SRC !lose heat + COMS%QI (COMS%L) = COMS%QI (COMS%L) - EVIDT !lose ice + + ENDIF !go on,unsatisfied +! + ELSE !not enough ice to last DT +! + IF (SD.LE.COMS%QI (COMS%L) ) THEN !but there is enough to sat + + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !use it + COMS%QI (COMS%L) = COMS%QI (COMS%L) - SD + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * SRC + + RETURN +! + ELSE !not enough to sat + SD = SD-COMS%QI (COMS%L) + COMS%QV (COMS%L) = COMS%QV (COMS%L) + COMS%QI (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) - COMS%QI (COMS%L) * SRC + COMS%QI (COMS%L) = 0.0 !all gone + + ENDIF !on to better things + !finished with ice + ENDIF +! +ENDIF !finished with the SD decision +! +RETURN +! +END SUBROUTINE EVAPORATE +! +! ********************************************************************* +SUBROUTINE CONVERT (coms) +! +!- ACCRETION AND AUTOCONVERSION +! +implicit none +type(plumegen_coms), pointer :: coms + +!use module_zero_plumegen_coms +! +real(kind=kind_phys), PARAMETER :: AK1 = 0.001 !conversion rate constant +real(kind=kind_phys), PARAMETER :: AK2 = 0.0052 !collection (accretion) rate +real(kind=kind_phys), PARAMETER :: TH = 0.5 !Kessler threshold +integer, PARAMETER :: iconv = 1 !- Kessler conversion (=0) + +!real(kind=kind_phys), parameter :: ANBASE = 50.!*1.e+6 !Berry-number at cloud base #/m^3(maritime) + real(kind=kind_phys), parameter :: ANBASE =100000.!*1.e+6 !Berry-number at cloud base #/m^3(continental) +!real(kind=kind_phys), parameter :: BDISP = 0.366 !Berry--size dispersion (maritime) + real(kind=kind_phys), parameter :: BDISP = 0.146 !Berry--size dispersion (continental) +real(kind=kind_phys), parameter :: TFREEZE = 269.3 !ice formation temperature +! +real(kind=kind_phys) :: accrete, con, q, h, bc1, bc2, total + + +IF (COMS%T (COMS%L) .LE. TFREEZE) RETURN !process not allowed above ice +! +IF (COMS%QC (COMS%L) .EQ. 0. ) RETURN + +ACCRETE = 0. +CON = 0. +Q = COMS%RHO (COMS%L) * COMS%QC (COMS%L) +H = COMS%RHO (COMS%L) * COMS%QH (COMS%L) +! +! selection rules +! +! +IF (COMS%QH (COMS%L) .GT. 0. ) ACCRETE = AK2 * Q * (H**.875) !accretion, Kessler +! +IF (ICONV.NE.0) THEN !select Berry or Kessler +! +!old BC1 = 120. +!old BC2 = .0266 * ANBASE * 60. +!old CON = BDISP * Q * Q * Q / (BC1 * Q * BDISP + BC2) + + CON = Q*Q*Q*BDISP/(60.*(5.*Q*BDISP+0.0366*ANBASE)) +! +ELSE +! +! CON = AK1 * (Q - TH) !Kessler autoconversion rate +! +! IF (CON.LT.0.0) CON = 0.0 !havent reached threshold + + CON = max(0.,AK1 * (Q - TH)) ! versao otimizada +! +ENDIF +! +! +TOTAL = (CON + ACCRETE) * COMS%DT / COMS%RHO (COMS%L) + +! +IF (TOTAL.LT.COMS%QC (COMS%L) ) THEN +! + COMS%QC (COMS%L) = COMS%QC (COMS%L) - TOTAL + COMS%QH (COMS%L) = COMS%QH (COMS%L) + TOTAL !no phase change involved + RETURN +! +ELSE +! + COMS%QH (COMS%L) = COMS%QH (COMS%L) + COMS%QC (COMS%L) !uses all there is + COMS%QC (COMS%L) = 0.0 +! +ENDIF +! +RETURN +! +END SUBROUTINE CONVERT +! +!********************************************************************** +! +SUBROUTINE SUBLIMATE(coms) +! +implicit none +type(plumegen_coms), pointer :: coms + +! ********************* VAPOR TO ICE (USE EQUATION OT22)*************** +!use module_zero_plumegen_coms +! +real(kind=kind_phys), PARAMETER :: EPS = 0.622, HEATFUS = 334., HEATSUBL = 2834., CP = 1.004 +real(kind=kind_phys), PARAMETER :: SRC = HEATSUBL / CP, FRC = HEATFUS / CP, TMELT = 273.3 +real(kind=kind_phys), PARAMETER :: TFREEZE = 269.3 + +real(kind=kind_phys) ::dtsubh, dividend,divisor, subl +! +DTSUBH = 0. +! +!selection criteria for sublimation +IF (COMS%T (COMS%L) .GT. TFREEZE ) RETURN +IF (COMS%QV (COMS%L) .LE. COMS%QSAT (COMS%L) ) RETURN +! +! from (OT); correction factors for units applied +! + DIVIDEND = ( (1.E6 / COMS%RHO (COMS%L) ) **0.475) * (COMS%QV (COMS%L) / COMS%QSAT (COMS%L) & + - 1) * (COMS%QI (COMS%L) **0.525) * 1.13 + DIVISOR = 7.E5 + 4.1E6 / (10. * COMS%EST (COMS%L) ) +! + + DTSUBH = ABS (DIVIDEND / DIVISOR) !sublimation rate + SUBL = DTSUBH * COMS%DT !and amount possible +! +! again check the possibilities +! +IF (SUBL.LT.COMS%QV (COMS%L) ) THEN +! + COMS%QV (COMS%L) = COMS%QV (COMS%L) - SUBL !lose vapor + COMS%QI (COMS%L) = COMS%QI (COMS%L) + SUBL !gain ice + COMS%T (COMS%L) = COMS%T (COMS%L) + SUBL * SRC !energy change, warms air + + RETURN +! +ELSE +! + COMS%QI (COMS%L) = COMS%QV (COMS%L) !use what there is + COMS%T (COMS%L) = COMS%T (COMS%L) + COMS%QV (COMS%L) * SRC !warm the air + COMS%QV (COMS%L) = 0.0 +! +ENDIF +! +RETURN +END SUBROUTINE SUBLIMATE +! +! ********************************************************************* +! +SUBROUTINE GLACIATE (coms) +! +! *********************** CONVERSION OF RAIN TO ICE ******************* +! uses equation OT 16, simplest. correction from W not applied, but +! vapor pressure differences are supplied. +! +!use module_zero_plumegen_coms +! +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), PARAMETER :: HEATFUS = 334., CP = 1.004, EPS = 0.622, HEATSUBL = 2834. +real(kind=kind_phys), PARAMETER :: FRC = HEATFUS / CP, FRS = HEATSUBL / CP, TFREEZE = 269.3 +real(kind=kind_phys), PARAMETER :: GLCONST = 0.025 !glaciation time constant, 1/sec +real(kind=kind_phys) dfrzh +! + + DFRZH = 0. !rate of mass gain in ice +! +!selection rules for glaciation +IF (COMS%QH (COMS%L) .LE. 0. ) RETURN +IF (COMS%QV (COMS%L) .LT. COMS%QSAT (COMS%L) ) RETURN +IF (COMS%T (COMS%L) .GT. TFREEZE ) RETURN +! +! NT=TMELT-COMS%T(COMS%L) +! IF (NT.GT.50) NT=50 +! + + DFRZH = COMS%DT * GLCONST * COMS%QH (COMS%L) ! from OT(16) +! +IF (DFRZH.LT.COMS%QH (COMS%L) ) THEN +! + COMS%QI (COMS%L) = COMS%QI (COMS%L) + DFRZH + COMS%QH (COMS%L) = COMS%QH (COMS%L) - DFRZH + COMS%T (COMS%L) = COMS%T (COMS%L) + FRC * DFRZH !warms air + + + RETURN +! +ELSE +! + COMS%QI (COMS%L) = COMS%QI (COMS%L) + COMS%QH (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) + FRC * COMS%QH (COMS%L) + COMS%QH (COMS%L) = 0.0 + + !print*,'8',coms%l,coms%qi(coms%l), COMS%QH (COMS%L) +! +ENDIF +! +RETURN +! +END SUBROUTINE GLACIATE +! +! +! ********************************************************************* +SUBROUTINE MELT(coms) +! +! ******************* MAKES WATER OUT OF ICE ************************** +!use module_zero_plumegen_coms +! +implicit none +type(plumegen_coms), pointer :: coms + +real(kind=kind_phys), PARAMETER :: FRC = 332.27, TMELT = 273., F0 = 0.75 !ice velocity factor +real(kind=kind_phys) DTMELT +! + DTMELT = 0. !conversion,ice to rain +! +!selection rules +IF (COMS%QI (COMS%L) .LE. 0.0 ) RETURN +IF (COMS%T (COMS%L) .LT. TMELT) RETURN +! + !OT(23,24) + DTMELT = COMS%DT * (2.27 / COMS%RHO (COMS%L) ) * COMS%CVI(COMS%L) * (COMS%T (COMS%L) - TMELT) * ( (COMS%RHO(COMS%L) & + * COMS%QI (COMS%L) * 1.E-6) **0.525) * (F0** ( - 0.42) ) + !after Mason,1956 +! +! check the possibilities +! +IF (DTMELT.LT.COMS%QI (COMS%L) ) THEN +! + COMS%QH (COMS%L) = COMS%QH (COMS%L) + DTMELT + COMS%QI (COMS%L) = COMS%QI (COMS%L) - DTMELT + COMS%T (COMS%L) = COMS%T (COMS%L) - FRC * DTMELT !cools air + + RETURN +! +ELSE +! + COMS%QH (COMS%L) = COMS%QH (COMS%L) + COMS%QI (COMS%L) !get all there is to get + COMS%T (COMS%L) = COMS%T (COMS%L) - FRC * COMS%QI (COMS%L) + COMS%QI (COMS%L) = 0.0 +! +ENDIF +! +RETURN +! +END SUBROUTINE MELT + +SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb) + IMPLICIT NONE + INTEGER, INTENT(IN ) :: nzz1 + INTEGER, INTENT(IN ) :: nzz2 + REAL(kind=kind_phys), INTENT(IN ) :: vctra(nzz1) + REAL(kind=kind_phys), INTENT(OUT) :: vctrb(nzz2) + REAL(kind=kind_phys), INTENT(IN ) :: eleva(nzz1) + REAL(kind=kind_phys), INTENT(IN ) :: elevb(nzz2) + + INTEGER :: l + INTEGER :: k + INTEGER :: kk + REAL(kind=kind_phys) :: wt + + l=1 + + DO k=1,nzz2 + DO + IF ( (elevb(k) < eleva(1)) .OR. & + ((elevb(k) >= eleva(l)) .AND. (elevb(k) <= eleva(l+1))) ) THEN + wt = (elevb(k)-eleva(l))/(eleva(l+1)-eleva(l)) + vctrb(k) = vctra(l)+(vctra(l+1)-vctra(l))*wt + EXIT + ELSE IF ( elevb(k) > eleva(nzz1)) THEN + wt = (elevb(k)-eleva(nzz1))/(eleva(nzz1-1)-eleva(nzz1)) + vctrb(k) = vctra(nzz1)+(vctra(nzz1-1)-vctra(nzz1))*wt + EXIT + END IF + + l=l+1 + IF(l == nzz1) THEN + PRINT *,'htint:nzz1',nzz1 + DO kk=1,l + PRINT*,'kk,eleva(kk),elevb(kk)',kk,eleva(kk),elevb(kk) + END DO + STOP 'htint' + END IF + END DO + END DO +END SUBROUTINE htint +!----------------------------------------------------------------------------- +FUNCTION ESAT_PR (TEM) +! +! ******* Vapor Pressure A.L. Buck JAM V.20 p.1527. (1981) *********** +! +real(kind=kind_phys), PARAMETER :: CI1 = 6.1115, CI2 = 22.542, CI3 = 273.48 +real(kind=kind_phys), PARAMETER :: CW1 = 6.1121, CW2 = 18.729, CW3 = 257.87, CW4 = 227.3 +real(kind=kind_phys), PARAMETER :: TMELT = 273.3 + +real(kind=kind_phys) ESAT_PR +real(kind=kind_phys) temc , tem,esatm +! +! formulae from Buck, A.L., JAM 20,1527-1532 +! custom takes esat wrt water always. formula for h2o only +! good to -40C so: +! +! +TEMC = TEM - TMELT +IF (TEMC.GT. - 40.0) GOTO 230 +ESATM = CI1 * EXP (CI2 * TEMC / (TEMC + CI3) ) !ice, millibars +ESAT_PR = ESATM / 10. !kPa + +RETURN +! +230 ESATM = CW1 * EXP ( ( (CW2 - (TEMC / CW4) ) * TEMC) / (TEMC + CW3)) + +ESAT_PR = ESATM / 10. !kPa +RETURN +END function ESAT_PR +! ****************************************************************** + +! ------------------------------------------------------------------------ +END Module module_smoke_plumerise diff --git a/smoke/module_zero_plumegen_coms.F90 b/smoke/module_zero_plumegen_coms.F90 new file mode 100755 index 000000000..d00554753 --- /dev/null +++ b/smoke/module_zero_plumegen_coms.F90 @@ -0,0 +1,192 @@ +module module_zero_plumegen_coms + + use machine , only : kind_phys + + implicit none + integer, parameter :: nkp = 200, ntime = 200 + + type plumegen_coms + real(kind=kind_phys),dimension(nkp) :: w,t,qv,qc,qh,qi,sc, & ! blob + vth,vti,rho,txs, & + est,qsat! never used: ,qpas,qtotal + + real(kind=kind_phys),dimension(nkp) :: wc,wt,tt,qvt,qct,qht,qit,sct + real(kind=kind_phys),dimension(nkp) :: dzm,dzt,zm,zt,vctr1,vctr2 & + ,vt3dc,vt3df,vt3dk,vt3dg,scr1 + + real(kind=kind_phys),dimension(nkp) :: pke,the,thve,thee,pe,te,qvenv,dne ! environment at plume grid ! never used: rhe, sce + real(kind=kind_phys),dimension(nkp) :: ucon,vcon,thtcon ,rvcon,picon,tmpcon & ! never used: wcon, dncon, prcon + ,zcon,zzcon ! environment at RAMS grid ! never used: scon + + real(kind=kind_phys) :: DZ,DQSDZ,VISC(nkp),VISCOSITY,TSTPF + integer :: N,NM1,L + ! + real(kind=kind_phys) :: CVH(nkp),CVI(nkp),ADIABAT,& + WBAR,VHREL,VIREL ! advection + ! Never used: ADVW,ADVT,ADVV,ADVC,ADVH,ADVI,ALAST(10) + + ! + real(kind=kind_phys) :: ZSURF,ZTOP ! never used: ZBASE + ! never used: integer :: LBASE + ! + real(kind=kind_phys) :: AREA,RSURF,ALPHA,RADIUS(nkp) ! entrain + ! + real(kind=kind_phys) :: HEATING(ntime),FMOIST,BLOAD ! heating + ! + real(kind=kind_phys) :: DT,TIME,TDUR + integer :: MINTIME,MDUR,MAXTIME + ! + !REAL(kind=kind_phys),DIMENSION(nkp,2) :: W_VMD,VMD + REAL(kind=kind_phys) :: upe (nkp) + REAL(kind=kind_phys) :: vpe (nkp) + REAL(kind=kind_phys) :: vel_e (nkp) + + REAL(kind=kind_phys) :: vel_p (nkp) + REAL(kind=kind_phys) :: rad_p (nkp) + REAL(kind=kind_phys) :: vel_t (nkp) + REAL(kind=kind_phys) :: rad_t (nkp) + + REAL(kind=kind_phys) :: ztop_(ntime) + integer :: testval + contains + procedure :: set_to_zero => plumegen_coms_zero + end type plumegen_coms + + interface plumegen_coms + procedure :: plumegen_coms_constructor + end interface plumegen_coms + + type(plumegen_coms), private, target :: private_thread_coms + logical, private :: mzpc_initialized = .false. + +!$OMP THREADPRIVATE(private_thread_coms) +!$OMP THREADPRIVATE(mzpc_initialized) + +contains + + function get_thread_coms() result(coms) + implicit none + class(plumegen_coms), pointer :: coms + if(.not.mzpc_initialized) then + private_thread_coms = plumegen_coms() + mzpc_initialized = .true. + endif + coms => private_thread_coms + end function get_thread_coms + + type(plumegen_coms) function plumegen_coms_constructor() result(this) + implicit none + call plumegen_coms_zero(this) + this%testval=3314 + end function plumegen_coms_constructor + + subroutine plumegen_coms_zero(this) + implicit none + class(plumegen_coms) :: this + + this%w=0.0 + this%t=0.0 + this%qv=0.0 + this%qc=0.0 + this%qh=0.0 + this%qi=0.0 + this%sc=0.0 + this%vth=0.0 + this%vti=0.0 + this%rho=0.0 + this%txs=0.0 + this%est=0.0 + this%qsat=0.0 + !this%qpas=0.0 + !this%qtotal=0.0 + this%wc=0.0 + this%wt=0.0 + this%tt=0.0 + this%qvt=0.0 + this%qct=0.0 + this%qht=0.0 + this%qit=0.0 + this%sct=0.0 + this%dzm=0.0 + this%dzt=0.0 + this%zm=0.0 + this%zt=0.0 + this%vctr1=0.0 + this%vctr2=0.0 + this%vt3dc=0.0 + this%vt3df=0.0 + this%vt3dk=0.0 + this%vt3dg=0.0 + this%scr1=0.0 + this%pke=0.0 + this%the=0.0 + this%thve=0.0 + this%thee=0.0 + this%pe=0.0 + this%te=0.0 + this%qvenv=0.0 + !this%rhe=0.0 + this%dne=0.0 + !this%sce=0.0 + this%ucon=0.0 + this%vcon=0.0 + !this%wcon=0.0 + this%thtcon =0.0 + this%rvcon=0.0 + this%picon=0.0 + this%tmpcon=0.0 + !this%dncon=0.0 + !this%prcon=0.0 + this%zcon=0.0 + this%zzcon=0.0 + !this%scon=0.0 + this%dz=0.0 + this%dqsdz=0.0 + this%visc=0.0 + this%viscosity=0.0 + this%tstpf=0.0 + !this%advw=0.0 + !this%advt=0.0 + !this%advv=0.0 + !this%advc=0.0 + !this%advh=0.0 + !this%advi=0.0 + this%cvh=0.0 + this%cvi=0.0 + this%adiabat=0.0 + this%wbar=0.0 + !this%alast=0.0 + this%vhrel=0.0 + this%virel=0.0 + this%zsurf=0.0 + !this%zbase=0.0 + this%ztop=0.0 + this%area=0.0 + this%rsurf=0.0 + this%alpha=0.0 + this%radius=0.0 + this%heating=0.0 + this%fmoist=0.0 + this%bload=0.0 + this%dt=0.0 + this%time=0.0 + this%tdur=0.0 + this%ztop_=0.0 + this%upe =0.0 + this%vpe =0.0 + this%vel_e =0.0 + this%vel_p =0.0 + this%rad_p =0.0 + this%vel_t =0.0 + this%rad_t =0.0 + !this%W_VMD=0.0 + !this%VMD=0.0 + this%n=0 + this%nm1=0 + this%l=0 + !this%lbase=0 + this%mintime=0 + this%mdur=0 + this%maxtime=0 + end subroutine plumegen_coms_zero +end module module_zero_plumegen_coms diff --git a/smoke/plume_data_mod.F90 b/smoke/plume_data_mod.F90 new file mode 100755 index 000000000..ce89dc4fd --- /dev/null +++ b/smoke/plume_data_mod.F90 @@ -0,0 +1,49 @@ +module plume_data_mod + + use machine , only : kind_phys + + implicit none + + ! -- FRP parameters + integer, dimension(0:20), parameter :: & + catb = (/ & + 0, & + 2, 1, 2, 1, & !floresta tropical 2 and 4 / extra trop fores 1,3,5 + 2, 3, 3, 3, 3, & !cerrado/woody savanna :6 a 9 + 4, 4, 4, 4, 4, 0, 4, 0, 0, 0, 0 & !pastagem/lavouras: 10 ... + /) + + real(kind=kind_phys), dimension(0:4), parameter :: & + flaming = (/ & + 0.00, & ! + 0.45, & ! % biomass burned at flaming phase : tropical forest igbp 2 and 4 + 0.45, & ! % biomass burned at flaming phase : extratropical forest igbp 1 , 3 and 5 + 0.75, & ! % biomass burned at flaming phase : cerrado/woody savanna igbp 6 to 9 + 0.00 & ! % biomass burned at flaming phase : pastagem/lavoura: igbp 10 a 17 + /) + + real(kind=kind_phys), dimension(0:20), parameter :: & + msize= (/ & + 0.00021, & !0near water,1Evergreen needleleaf,2EvergreenBroadleaf,!3Deciduous Needleleaf,4Deciduous Broadleaf + 0.00021, 0.00021, 0.00021, 0.00021, & !5Mixed forest,6Closed shrublands,7Open shrublands,8Woody savannas,9Savannas, + 0.00023, 0.00022, 0.00022, 0.00022, 0.00029, &! 10Grassland,11Permanent wetlands,12cropland,13'Urban and Built-Up' + 0.00029, 0.00021, 0.00026, 0.00021, 0.00026, &!14cropland/natural vegetation mosaic,15Snow and ice,16Barren or sparsely vegetated + 0.00021, 0.00021, 0.00021, 0.00021, 0.00021, 0.00021 & !17Water,18Wooded Tundra,19Mixed Tundra,20Bare Ground Tundra + /) + + ! -- FRP buffer indices + integer, parameter :: p_frp_hr = 1 + integer, parameter :: p_frp_std = 2 + integer, parameter :: num_frp_plume = 2 + + ! -- plumerise parameters + integer, parameter :: tropical_forest = 1 + integer, parameter :: boreal_forest = 2 + integer, parameter :: savannah = 3 + integer, parameter :: grassland = 4 + integer, parameter :: nveg_agreg = 4 + integer, parameter :: wind_eff = 1 + + public + +end module plume_data_mod diff --git a/smoke/readme b/smoke/readme deleted file mode 100644 index e8027d7fa..000000000 --- a/smoke/readme +++ /dev/null @@ -1 +0,0 @@ -the smoke directory diff --git a/smoke/rrfs_smoke_config.F90 b/smoke/rrfs_smoke_config.F90 new file mode 100755 index 000000000..f3cdd13c9 --- /dev/null +++ b/smoke/rrfs_smoke_config.F90 @@ -0,0 +1,125 @@ +! +! Haiqin.Li@noaa.gov +! 06/2021 +! constant parameters and chemistry configurations and tracers +! (This will be splited into three subroutine for configuration, constant and tracers later) +! 06/2021 move configuration into chem nml +! +module rrfs_smoke_config + + use machine , only : kind_phys + + implicit none + + !-- constant paramters + real(kind=kind_phys), parameter :: epsilc = 1.e-12 + + !-- chemistyr module configurations + integer :: chem_opt = 1 + integer :: kemit = 1 + integer :: dust_opt = 5 + integer :: dmsemis_opt = 1 + integer :: seas_opt = 2 + integer :: biomass_burn_opt=1 + logical :: do_plumerise = .true. + integer :: addsmoke_flag = 1 + integer :: plumerisefire_frq=60 ! Let's add to the namelist + integer :: chem_conv_tr = 0 + integer :: aer_ra_feedback=1 !0 + integer :: aer_ra_frq = 60 + integer :: wetdep_ls_opt = 1 + integer :: drydep_opt = 1 + logical :: bb_dcycle = .false. + logical :: smoke_forecast = .false. + logical :: aero_ind_fdb = .false. + logical :: dbg_opt = .true. + + real(kind=kind_phys), parameter :: depo_fact=0. + integer, parameter :: CHEM_OPT_GOCART= 1 + INTEGER, PARAMETER :: gocartracm_kpp = 301 + integer, parameter :: chem_tune_tracers = 20 + integer, parameter :: DUST_OPT_NONE = 0 + integer, parameter :: SEAS_OPT_NONE = 0 + ! -- DMS emissions + integer, parameter :: DMSE_OPT_NONE = 0 + integer, parameter :: DMSE_OPT_ENABLE = 1 + ! -- subgrid convective transport + integer, parameter :: CTRA_OPT_NONE = 0 + integer, parameter :: CTRA_OPT_GRELL = 2 + ! -- large scale wet deposition + integer, parameter :: WDLS_OPT_NONE = 0 + integer, parameter :: WDLS_OPT_GSD = 1 + integer, parameter :: WDLS_OPT_NGAC = 2 + + ! -- + integer, parameter :: call_chemistry = 1 + integer, parameter :: num_moist=3, num_chem=20, num_emis_seas=5, num_emis_dust=5 + integer, parameter :: num_emis_ant = 7 + + integer, parameter :: SEAS_OPT_DEFAULT = 1 + + integer, parameter :: DUST_OPT_GOCART = 1 + integer, parameter :: DUST_OPT_AFWA = 3 + integer, parameter :: DUST_OPT_FENGSHA = 5 + + ! -- biomass burning emissions + integer, parameter :: BURN_OPT_ENABLE = 1 + integer, parameter :: FIRE_OPT_MODIS = 1 + integer, parameter :: FIRE_OPT_GBBEPx = 2 + + ! -- hydrometeors + integer, parameter :: p_qv=1 + integer, parameter :: p_qc=2 + integer, parameter :: p_qi=3 + ! -- set pointers to predefined atmospheric tracers + ! -- FV3 GFDL microphysics + integer, parameter :: p_atm_shum = 1 + integer, parameter :: p_atm_cldq = 2 + integer, parameter :: p_atm_o3mr = 7 + + integer :: numgas = 0 + + real(kind=kind_phys) :: wetdep_ls_alpha(chem_tune_tracers)=-999. + + !-- tracers + integer, parameter :: p_so2=1 + integer, parameter :: p_sulf=2 + integer, parameter :: p_dms=3 + integer, parameter :: p_msa=4 + integer, parameter :: p_p25=5, p_smoke=5 + integer, parameter :: p_bc1=6 + integer, parameter :: p_bc2=7 + integer, parameter :: p_oc1=8 + integer, parameter :: p_oc2=9 + integer, parameter :: p_dust_1=10 + integer, parameter :: p_dust_2=11 + integer, parameter :: p_dust_3=12 + integer, parameter :: p_dust_4=13 + integer, parameter :: p_dust_5=14 + integer, parameter :: p_seas_1=15 + integer, parameter :: p_seas_2=16 + integer, parameter :: p_seas_3=17 + integer, parameter :: p_seas_4=18 + integer, parameter :: p_seas_5=19 + integer, parameter :: p_p10 =20 + + integer, parameter :: p_edust1=1,p_edust2=2,p_edust3=3,p_edust4=4,p_edust5=5 + integer, parameter :: p_eseas1=1,p_eseas2=2,p_eseas3=3,p_eseas4=4,p_eseas5=5 + + integer :: p_ho=0,p_h2o2=0,p_no3=0 + + ! constants + real(kind=kind_phys), PARAMETER :: airmw = 28.97 + real(kind=kind_phys), PARAMETER :: mw_so2_aer = 64.066 + real(kind=kind_phys), PARAMETER :: mw_so4_aer = 96.066 + real(kind=kind_phys), parameter :: smw = 32.00 + real(kind=kind_phys), parameter :: mwdry = 28. +! d is the molecular weight of dry air (28.966), w/d = 0.62197, and +! (d - w)/d = 0.37803 +! http://atmos.nmsu.edu/education_and_outreach/encyclopedia/humidity.htm + + ! -- fire options +! integer, parameter :: num_plume_data = 1 + + +end module diff --git a/smoke/rrfs_smoke_data.F90 b/smoke/rrfs_smoke_data.F90 new file mode 100755 index 000000000..b5dbf5199 --- /dev/null +++ b/smoke/rrfs_smoke_data.F90 @@ -0,0 +1,644 @@ +module rrfs_smoke_data + use machine , only : kind_phys + implicit none + INTEGER, PARAMETER :: dep_seasons = 5 + INTEGER, PARAMETER :: nlu = 25 + + type wesely_pft + integer :: npft + integer :: months + INTEGER, pointer :: seasonal_wes(:,:,:,:) => NULL() + contains + final :: wesely_pft_destructor + end type wesely_pft + + interface wesely_pft + procedure :: wesely_pft_constructor + end interface wesely_pft + +!-------------------------------------------------- +! many of these parameters will depend on the RADM mechanism! +! if you change it, lets talk about it and get it done!!! +!-------------------------------------------------- + + REAL(kind_phys), parameter :: small_value = 1.e-36 + REAL(kind_phys), parameter :: large_value = 1.e36 + +!-------------------------------------------------- +! following currently hardwired to USGS +!-------------------------------------------------- + integer, parameter :: isice_temp = 24 + integer, parameter :: iswater_temp = 16 + integer, parameter :: wrf2mz_lt_map(nlu) = (/ 1, 2, 2, 2, 2, & + 4, 3, 3, 3, 3, & + 4, 5, 4, 5, 6, & + 7, 9, 6, 8, 9, & + 6, 6, 8, 0, 0 /) + real(kind_phys), parameter :: wh2o = 18.0153 + real(kind_phys), parameter :: wpan = 121.04793 + real(kind_phys), PARAMETER :: KARMAN=0.4 + INTEGER, parameter :: luse2usgs(21) = (/14,13,12,11,15,8,9,10,10,7, & + 17,4,1,5,24,19,16,21,22,23,16 /) + character(len=4), parameter :: mminlu = 'USGS' + + ! integer, parameter :: pan_seasons = 5 + ! integer, parameter :: pan_lands = 11 + + type smoke_data + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! Taken from dep_simple_mod + INTEGER :: ixxxlu(nlu) + REAL(KIND_PHYS) :: kpart(nlu) + REAL(KIND_PHYS) :: rac(nlu,dep_seasons), rclo(nlu,dep_seasons), rcls(nlu,dep_seasons) + REAL(KIND_PHYS) :: rgso(nlu,dep_seasons), rgss(nlu,dep_seasons) + REAL(KIND_PHYS) :: ri(nlu,dep_seasons), rlu(nlu,dep_seasons) + ! REAL(KIND_PHYS) :: ri_pan(pan_seasons,pan_lands) + ! never used: real(kind_phys) :: c0_pan(pan_lands) + ! never used: real(kind_phys) :: k_pan (pan_lands) + + ! never used: integer :: month + REAL(KIND_PHYS) :: dratio(1000), hstar(1000), hstar4(1000) + REAL(KIND_PHYS) :: f0(1000), dhr(1000), scpr23(1000) + + ! Note: scpr23 is only read, never written + + ! never used: type(wesely_pft) :: seasonal_pft + + ! never used: logical, pointer :: is_aerosol(:) => NULL() + + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! Taken from dep_wet_ls_mod + real(kind_phys), dimension(:), pointer :: alpha => NULL() + contains + final :: smoke_data_destructor + procedure :: dep_init + end type smoke_data + + interface smoke_data + procedure :: smoke_data_constructor + end interface smoke_data + + type(smoke_data), target, private :: private_thread_data + logical, private :: rrfs_smoke_data_initialized = .false. + + !$OMP THREADPRIVATE(private_thread_data) + !$OMP THREADPRIVATE(rrfs_smoke_data_initialized) + +contains + + function get_thread_smoke_data() result(data) + implicit none + class(smoke_data), pointer :: data + if(.not. rrfs_smoke_data_initialized) then + private_thread_data = smoke_data() + rrfs_smoke_data_initialized = .true. + endif + data => private_thread_data + end function get_thread_smoke_data + + subroutine wesely_pft_destructor(this) + implicit none + type(wesely_pft) :: this + if(associated(this%seasonal_wes)) then + deallocate(this%seasonal_wes) + nullify(this%seasonal_wes) + endif + end subroutine wesely_pft_destructor + + function wesely_pft_constructor() result(this) + implicit none + class(wesely_pft), pointer :: this + nullify(this%seasonal_wes) + end function wesely_pft_constructor + + function smoke_data_constructor() result(this) + implicit none + type(smoke_data) :: this + ! These are never used: + ! this%c0_pan = (/ 0.000, 0.006, 0.002, 0.009, 0.015, & + ! 0.006, 0.000, 0.000, 0.000, 0.002, 0.002 /) + ! this%k_pan = (/ 0.000, 0.010, 0.005, 0.004, 0.003, & + ! 0.005, 0.000, 0.000, 0.000, 0.075, 0.002 /) + ! this%month = 0 + ! this%seasonal_pft = wesely_pft() + ! nullify(this%is_aerosol) + nullify(this%alpha) + ! This is not called in the original non-thread-safe code: + ! call this%dep_init() + end function smoke_data_constructor + + subroutine smoke_data_destructor(this) + implicit none + type(smoke_data) :: this + if(associated(this%alpha)) then + deallocate(this%alpha) + nullify(this%alpha) + endif + ! Never used: + ! if(associated(this%is_aerosol)) then + ! deallocate(this%is_aerosol) + ! nullify(this%is_aerosolo) + ! endif + end subroutine smoke_data_destructor + + +! SUBROUTINE dep_init( id, numgas, mminlu_loc, & +! ips, ipe, jps, jpe, ide, jde ) + SUBROUTINE dep_init(this) + ! Lifted out of dep_simple_mod, this initializes + ! member variables that were module variables in + ! that module. +!-- + implicit none + class(smoke_data) :: this + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + ! Unused: + ! integer, intent(in) :: numgas + ! integer, intent(in) :: ips, ipe, jps, jpe + ! integer, intent(in) :: ide, jde + ! mmin_lu_loc had no definition, but is also unused + +!-------------------------------------------------- +! .. Local Scalars +!-------------------------------------------------- + INTEGER :: iland, iseason, l + integer :: iprt + integer :: astat + integer :: ncid + integer :: dimid + integer :: varid + integer :: cpos, slen + integer :: lon_e, lat_e + integer :: iend, jend + integer :: chem_opt + integer, allocatable :: input_wes_seasonal(:,:,:,:) + REAL(KIND_PHYS) :: sc + character(len=128) :: err_msg + character(len=128) :: filename + character(len=3) :: id_num +!-------------------------------------------------- +! .. Local Arrays +!-------------------------------------------------- + REAL(KIND_PHYS) :: dat1(nlu,dep_seasons), dat2(nlu,dep_seasons), & + dat3(nlu,dep_seasons), dat4(nlu,dep_seasons), & + dat5(nlu,dep_seasons), dat6(nlu,dep_seasons), & + dat7(nlu,dep_seasons) + ! REAL(KIND_PHYS) :: dat8(pan_seasons,pan_lands) + chem_opt = chem_opt + +!-------------------------------------------------- +! .. Data Statements .. +! THIS%RI for stomatal resistance +! data ((this%ri(ILAND,ISEASON),ILAND=1,nlu),ISEASON=1,dep_seasons)/0.10E+11, & + DATA ((dat1(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.60E+02, 0.60E+02, 0.60E+02, 0.60E+02, 0.70E+02, 0.12E+03, & + 0.12E+03, 0.12E+03, 0.12E+03, 0.70E+02, 0.13E+03, 0.70E+02, & + 0.13E+03, 0.10E+03, 0.10E+11, 0.80E+02, 0.10E+03, 0.10E+11, & + 0.80E+02, 0.10E+03, 0.10E+03, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, 0.10E+11, & + 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, & + 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, & + 0.10E+11, 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, & + 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.70E+02, 0.40E+03, 0.80E+03, 0.10E+11, & + 0.10E+11, 0.80E+03, 0.10E+11, 0.10E+11, 0.80E+03, 0.80E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.12E+03, & + 0.12E+03, 0.12E+03, 0.14E+03, 0.24E+03, 0.24E+03, 0.24E+03, & + 0.12E+03, 0.14E+03, 0.25E+03, 0.70E+02, 0.25E+03, 0.19E+03, & + 0.10E+11, 0.16E+03, 0.19E+03, 0.10E+11, 0.16E+03, 0.19E+03, & + 0.19E+03, 0.10E+11, 0.10E+11, 0.10E+11/ +! .. + IF (nlu/=25) THEN + write(0,*) 'number of land use classifications not correct ' + stop + END IF + IF (dep_seasons/=5) THEN + write(0,*) 'number of dep_seasons not correct ' + stop + END IF + +! SURFACE RESISTANCE DATA FOR DEPOSITION MODEL OF +! M. L. WESELY, ATMOSPHERIC ENVIRONMENT 23 (1989) 1293-1304 + +! Seasonal categories: +! 1: midsummer with lush vegetation +! 2: autumn with unharvested cropland +! 3: late autumn with frost, no snow +! 4: winter, snow on ground and subfreezing +! 5: transitional spring with partially green short annuals + +! Land use types: +! USGS type Wesely type +! 1: Urban and built-up land 1 +! 2: Dryland cropland and pasture 2 +! 3: Irrigated cropland and pasture 2 +! 4: Mix. dry/irrg. cropland and pasture 2 +! 5: Cropland/grassland mosaic 2 +! 6: Cropland/woodland mosaic 4 +! 7: Grassland 3 +! 8: Shrubland 3 +! 9: Mixed shrubland/grassland 3 +! 10: Savanna 3, always summer +! 11: Deciduous broadleaf forest 4 +! 12: Deciduous needleleaf forest 5, autumn and winter modi +! 13: Evergreen broadleaf forest 4, always summer +! 14: Evergreen needleleaf forest 5 +! 15: Mixed Forest 6 +! 16: Water Bodies 7 +! 17: Herbaceous wetland 9 +! 18: Wooded wetland 6 +! 19: Barren or sparsely vegetated 8 +! 20: Herbaceous Tundra 9 +! 21: Wooded Tundra 6 +! 22: Mixed Tundra 6 +! 23: Bare Ground Tundra 8 +! 24: Snow or Ice -, always winter +! 25: No data 8 + + +! Order of data: +! | +! | seasonal category +! \|/ +! ---> landuse type +! 1 2 3 4 5 6 7 8 9 +! THIS%RLU for outer surfaces in the upper canopy + DO iseason = 1, dep_seasons + this%ri(1:nlu,iseason) = dat1(1:nlu,iseason) + END DO +! data ((this%rlu(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat2(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & + 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & + 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, & + 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & + 0.90E+04, 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, & + 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.20E+04, 0.60E+04, 0.90E+04, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & + 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & + 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & + 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & + 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ + DO iseason = 1, dep_seasons + this%rlu(1:nlu,iseason) = dat2(1:nlu,iseason) + END DO +! THIS%RAC for transfer that depends on canopy height and density +! data ((this%rac(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+03, & + DATA ((dat3(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+04, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.00E+00, 0.30E+03, 0.20E+04, 0.00E+00, & + 0.30E+03, 0.20E+04, 0.20E+04, 0.00E+00, 0.00E+00, 0.00E+00, & + 0.10E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+04, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.15E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.17E+04, 0.00E+00, 0.20E+03, 0.17E+04, & + 0.00E+00, 0.20E+03, 0.17E+04, 0.17E+04, 0.00E+00, 0.00E+00, & + 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, 0.10E+03, & + 0.15E+04, 0.00E+00, 0.10E+03, 0.15E+04, 0.15E+04, 0.00E+00, & + 0.00E+00, 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+02, 0.10E+04, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, & + 0.50E+02, 0.15E+04, 0.00E+00, 0.50E+02, 0.15E+04, 0.15E+04, & + 0.00E+00, 0.00E+00, 0.00E+00, 0.10E+03, 0.50E+02, 0.50E+02, & + 0.50E+02, 0.50E+02, 0.12E+04, 0.80E+02, 0.80E+02, 0.80E+02, & + 0.10E+03, 0.12E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, & + 0.00E+00, 0.20E+03, 0.15E+04, 0.00E+00, 0.20E+03, 0.15E+04, & + 0.15E+04, 0.00E+00, 0.00E+00, 0.00E+00/ + DO iseason = 1, dep_seasons + this%rac(1:nlu,iseason) = dat3(1:nlu,iseason) + END DO +! THIS%RGSS for ground surface SO2 +! data ((this%rgss(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.40E+03, & + DATA ((dat4(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.40E+03, & + 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, & + 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, & + 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, 0.10E+04, & + 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+04, & + 0.40E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.50E+03, & + 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, & + 0.50E+03, 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, & + 0.10E+04, 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, & + 0.10E+04, 0.40E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & + 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, & + 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, 0.10E+01, 0.10E+01, & + 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, 0.20E+03, 0.10E+04, & + 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.50E+03, 0.10E+03, 0.10E+03, 0.10E+01, & + 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+04, 0.10E+03, 0.10E+04, 0.50E+03, 0.15E+03, 0.15E+03, & + 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, & + 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, & + 0.10E+01, 0.10E+01, 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, & + 0.20E+03, 0.10E+04, 0.10E+03, 0.10E+04/ + DO iseason = 1, dep_seasons + this%rgss(1:nlu,iseason) = dat4(1:nlu,iseason) + END DO +! THIS%RGSO for ground surface O3 +! data ((this%rgso(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.30E+03, & + DATA ((dat5(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.30E+03, & + 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, & + 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03, & + 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.80E+03, 0.30E+03, & + 0.40E+03, 0.80E+03, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, & + 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, & + 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, & + 0.35E+04, 0.40E+03, 0.60E+03, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.35E+04, 0.35E+04, 0.20E+03, 0.35E+04, 0.35E+04, 0.20E+04, & + 0.35E+04, 0.35E+04, 0.40E+03, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.40E+03, 0.35E+04, 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, & + 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, & + 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, & + 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03/ + DO iseason = 1, dep_seasons + this%rgso(1:nlu,iseason) = dat5(1:nlu,iseason) + END DO +! THIS%RCLS for exposed surfaces in the lower canopy SO2 +! data ((this%rcls(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat6(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & + 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & + 0.20E+04, 0.20E+04, 0.40E+04, 0.10E+11, 0.90E+04, 0.40E+04, & + 0.10E+11, 0.90E+04, 0.40E+04, 0.40E+04, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & + 0.90E+04, 0.20E+04, 0.30E+04, 0.60E+04, 0.10E+11, 0.90E+04, & + 0.60E+04, 0.10E+11, 0.90E+04, 0.60E+04, 0.60E+04, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.20E+04, 0.20E+03, 0.40E+03, 0.10E+11, & + 0.90E+04, 0.40E+03, 0.10E+11, 0.90E+04, 0.40E+03, 0.40E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & + 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & + 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & + 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & + 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ + DO iseason = 1, dep_seasons + this%rcls(1:nlu,iseason) = dat6(1:nlu,iseason) + END DO +! THIS%RCLO for exposed surfaces in the lower canopy O3 +! data ((this%rclo(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat7(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+11, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, & + 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, 0.40E+03, & + 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.40E+03, 0.60E+03, & + 0.10E+11, 0.40E+03, 0.60E+03, 0.60E+03, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, & + 0.40E+03, 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.80E+03, & + 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.40E+03, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.40E+03, 0.40E+03, 0.10E+04, 0.15E+04, 0.60E+03, 0.10E+11, & + 0.80E+03, 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, & + 0.10E+04, 0.50E+03, 0.15E+04, 0.10E+04, 0.15E+04, 0.70E+03, & + 0.10E+11, 0.60E+03, 0.70E+03, 0.10E+11, 0.60E+03, 0.70E+03, & + 0.70E+03, 0.10E+11, 0.10E+11, 0.10E+11/ + + DO iseason = 1, dep_seasons + this%rclo(1:nlu,iseason) = dat7(1:nlu,iseason) + END DO + + ! data ((dat8(iseason,iland),iseason=1,pan_seasons),iland=1,pan_lands) / & + ! 1.e36, 60., 120., 70., 130., 100.,1.e36,1.e36, 80., 100., 150., & + ! 1.e36,1.e36,1.e36,1.e36, 250., 500.,1.e36,1.e36,1.e36,1.e36,1.e36, & + ! 1.e36,1.e36,1.e36,1.e36, 250., 500.,1.e36,1.e36,1.e36,1.e36,1.e36, & + ! 1.e36,1.e36,1.e36,1.e36, 400., 800.,1.e36,1.e36,1.e36,1.e36,1.e36, & + ! 1.e36, 120., 240., 140., 250., 190.,1.e36,1.e36, 160., 200., 300. / + ! this%ri_pan(:,:) = dat8(:,:) + +!-------------------------------------------------- +! Initialize parameters +!-------------------------------------------------- + this%hstar = 0. + this%hstar4 = 0. + this%dhr = 0. + this%f0 = 0. + this%dratio = 1.0 ! FIXME: IS THIS RIGHT? + this%scpr23 = 1.0 ! FIXME: IS THIS RIGHT? + +!-------------------------------------------------- +! HENRY''S LAW COEFFICIENTS +! Effective Henry''s law coefficient at pH 7 +! [KH298]=mole/(l atm) +!-------------------------------------------------- + +! DATA FOR AEROSOL PARTICLE DEPOSITION FOR THE MODEL OF +! J. W. ERISMAN, A. VAN PUL AND P. WYERS +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 + +! vd = (u* / k) * CORRECTION FACTORS + +! CONSTANT K FOR LANDUSE TYPES: +! urban and built-up land + this%kpart(1) = 500. +! dryland cropland and pasture + this%kpart(2) = 500. +! irrigated cropland and pasture + this%kpart(3) = 500. +! mixed dryland/irrigated cropland and past + this%kpart(4) = 500. +! cropland/grassland mosaic + this%kpart(5) = 500. +! cropland/woodland mosaic + this%kpart(6) = 100. +! grassland + this%kpart(7) = 500. +! shrubland + this%kpart(8) = 500. +! mixed shrubland/grassland + this%kpart(9) = 500. +! savanna + this%kpart(10) = 500. +! deciduous broadleaf forest + this%kpart(11) = 100. +! deciduous needleleaf forest + this%kpart(12) = 100. +! evergreen broadleaf forest + this%kpart(13) = 100. +! evergreen needleleaf forest + this%kpart(14) = 100. +! mixed forest + this%kpart(15) = 100. +! water bodies + this%kpart(16) = 500. +! herbaceous wetland + this%kpart(17) = 500. +! wooded wetland + this%kpart(18) = 500. +! barren or sparsely vegetated + this%kpart(19) = 500. +! herbaceous tundra + this%kpart(20) = 500. +! wooded tundra + this%kpart(21) = 100. +! mixed tundra + this%kpart(22) = 500. +! bare ground tundra + this%kpart(23) = 500. +! snow or ice + this%kpart(24) = 500. +! Comments: + this%kpart(25) = 500. +! Erisman et al. (1994) give +! k = 500 for low vegetation and k = 100 for forests. + +! For desert k = 500 is taken according to measurements +! on bare soil by +! J. Fontan, A. Lopez, E. Lamaud and A. Druilhet (1997) +! Vertical Flux Measurements of the Submicronic Aerosol Particles +! and Parametrisation of the Dry Deposition Velocity +! in: Biosphere-Atmosphere Exchange of Pollutants +! and Trace Substances +! Editor: S. Slanina. Springer-Verlag Berlin, Heidelberg, 1997 +! pp. 381-390 + +! For coniferous forest the Erisman value of k = 100 is taken. +! Measurements of Erisman et al. (1997) in a coniferous forest +! in the Netherlands, lead to values of k between 20 and 38 +! (Atmospheric Environment 31 (1997), 321-332). +! However, these high values of vd may be reached during +! instable cases. The eddy correlation measurements +! of Gallagher et al. (1997) made during the same experiment +! show for stable cases (L>0) values of k between 200 and 250 +! at minimum (Atmospheric Environment 31 (1997), 359-373). +! Fontan et al. (1997) found k = 250 in a forest +! of maritime pine in southwestern France. + +! For gras, model calculations of Davidson et al. support +! the value of 500. +! C. I. Davidson, J. M. Miller and M. A. Pleskov +! The Influence of Surface Structure on Predicted Particles +! Dry Deposition to Natural Gras Canopies +! Water, Air, and Soil Pollution 18 (1982) 25-43 + +! Snow covered surface: The experiment of Ibrahim et al. (1983) +! gives k = 436 for 0.7 um diameter particles. +! The deposition velocity of Milford and Davidson (1987) +! gives k = 154 for continental sulfate aerosol. +! M. Ibrahim, L. A. Barrie and F. Fanaki +! Atmospheric Environment 17 (1983), 781-788 + +! J. B. Milford and C. I. Davidson +! The Sizes of Particulate Sulfate and Nitrate in the Atmosphere +! - A Review +! JAPCA 37 (1987), 125-134 +! no data +! WRITE (0,*) ' return from rcread ' +! ********************************************************* + +! Simplified landuse scheme for deposition and biogenic emission +! subroutines +! (ISWATER and ISICE are already defined elsewhere, +! therefore water and ice are not considered here) + +! 1 urban or bare soil +! 2 agricultural +! 3 grassland +! 4 deciduous forest +! 5 coniferous and mixed forest +! 6 other natural landuse categories + + + IF (mminlu=='OLD ') THEN + this%ixxxlu(1) = 1 + this%ixxxlu(2) = 2 + this%ixxxlu(3) = 3 + this%ixxxlu(4) = 4 + this%ixxxlu(5) = 5 + this%ixxxlu(6) = 5 + this%ixxxlu(7) = 0 + this%ixxxlu(8) = 6 + this%ixxxlu(9) = 1 + this%ixxxlu(10) = 6 + this%ixxxlu(11) = 0 + this%ixxxlu(12) = 4 + this%ixxxlu(13) = 6 + END IF + IF (mminlu=='USGS') THEN + this%ixxxlu(1) = 1 + this%ixxxlu(2) = 2 + this%ixxxlu(3) = 2 + this%ixxxlu(4) = 2 + this%ixxxlu(5) = 2 + this%ixxxlu(6) = 4 + this%ixxxlu(7) = 3 + this%ixxxlu(8) = 6 + this%ixxxlu(9) = 3 + this%ixxxlu(10) = 6 + this%ixxxlu(11) = 4 + this%ixxxlu(12) = 5 + this%ixxxlu(13) = 4 + this%ixxxlu(14) = 5 + this%ixxxlu(15) = 5 + this%ixxxlu(16) = 0 + this%ixxxlu(17) = 6 + this%ixxxlu(18) = 4 + this%ixxxlu(19) = 1 + this%ixxxlu(20) = 6 + this%ixxxlu(21) = 4 + this%ixxxlu(22) = 6 + this%ixxxlu(23) = 1 + this%ixxxlu(24) = 0 + this%ixxxlu(25) = 1 + END IF + IF (mminlu=='SiB ') THEN + this%ixxxlu(1) = 4 + this%ixxxlu(2) = 4 + this%ixxxlu(3) = 4 + this%ixxxlu(4) = 5 + this%ixxxlu(5) = 5 + this%ixxxlu(6) = 6 + this%ixxxlu(7) = 3 + this%ixxxlu(8) = 6 + this%ixxxlu(9) = 6 + this%ixxxlu(10) = 6 + this%ixxxlu(11) = 1 + this%ixxxlu(12) = 2 + this%ixxxlu(13) = 6 + this%ixxxlu(14) = 1 + this%ixxxlu(15) = 0 + this%ixxxlu(16) = 0 + this%ixxxlu(17) = 1 + END IF + + END SUBROUTINE dep_init +end module rrfs_smoke_data diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/smoke/rrfs_smoke_lsdep_wrapper.F90 new file mode 100644 index 000000000..8625fe844 --- /dev/null +++ b/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -0,0 +1,338 @@ +!>\file rrfs_smoke_lsdep_wrapper.F90 +!! This file is RRFS-smoke large-scale wet deposition wrapper with CCPP +!! Haiqin.Li@noaa.gov 04/2021 + + module rrfs_smoke_lsdep_wrapper + + use physcons, only : g => con_g, pi => con_pi + use machine , only : kind_phys + use rrfs_smoke_config + use dep_wet_ls_mod + use dust_data_mod + use rrfs_smoke_data + + implicit none + + private + + public :: rrfs_smoke_lsdep_wrapper_init, rrfs_smoke_lsdep_wrapper_run, rrfs_smoke_lsdep_wrapper_finalize + +contains + +!> \brief Brief description of the subroutine +!! + subroutine rrfs_smoke_lsdep_wrapper_init() + end subroutine rrfs_smoke_lsdep_wrapper_init + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_rrfs_smoke_lsdep_wrapper_finalize Argument Table +!! + subroutine rrfs_smoke_lsdep_wrapper_finalize() + end subroutine rrfs_smoke_lsdep_wrapper_finalize + +!> \defgroup gsd_chem_group GSD Chem driver Module +!! This is the gsd chemistry +!>\defgroup rrfs_smoke_lsdep_wrapper GSD Chem driver Module +!> \ingroup gsd_chem_group +!! This is the GSD Chem driver Module +!! \section arg_table_rrfs_smoke_lsdep_wrapper_run Argument Table +!! \htmlinclude rrfs_smoke_lsdep_wrapper_run.html +!! +!>\section rrfs_smoke_lsdep_wrapper GSD Chemistry Scheme General Algorithm +!> @{ + subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & + rain_cpl, rainc_cpl, & + pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, & + w, dqdt, ntrac,ntsmoke,ntdust, & + gq0,qgrs,wetdep_ls_opt_in, & + errmsg,errflg) + + implicit none + + + integer, intent(in) :: im,kte,kme,ktau + integer, intent(in) :: ntrac,ntsmoke,ntdust + real(kind_phys),intent(in) :: dt + + integer, parameter :: ids=1,jds=1,jde=1, kds=1 + integer, parameter :: ims=1,jms=1,jme=1, kms=1 + integer, parameter :: its=1,jts=1,jte=1, kts=1 + + real(kind_phys), dimension(im), intent(in) :: rain_cpl, rainc_cpl + real(kind_phys), dimension(im,kme), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(im,kte), intent(in) :: phl3d, prl3d, tk3d, & + us3d, vs3d, spechum, w, dqdt + real(kind_phys), dimension(im,kte,ntrac), intent(inout) :: gq0, qgrs + integer, intent(in) :: wetdep_ls_opt_in + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(kind_phys), dimension(1:im, 1:kme,jms:jme) :: rri, t_phy, u_phy, v_phy, & + p_phy, z_at_w, dz8w, p8w, t8w, rho_phy, vvel, dqdti + + real(kind_phys), dimension(ims:im, jms:jme) :: rcav, rnav + +!>- vapor & chemistry variables + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem + real(kind_phys), dimension(ims:im, jms:jme, 1:num_chem ) :: var_rmv + + integer :: ide, ime, ite, kde + + real(kind_phys) :: dtstep + real(kind_phys), dimension(1:num_chem) :: ppm2ugkg + + type(smoke_data), pointer :: data + +!>-- local variables + integer :: i, j, jp, k, kp, n + + data=>get_thread_smoke_data() + + errmsg = '' + errflg = 0 + + wetdep_ls_opt = wetdep_ls_opt_in + !print*,'hli wetdep_ls_opt',wetdep_ls_opt + + ! -- set domain + ide=im + ime=im + ite=im + kde=kte + + ! -- volume to mass fraction conversion table (ppm -> ug/kg) + ppm2ugkg = 1._kind_phys + !ppm2ugkg(p_so2 ) = 1.e+03_kind_phys * mw_so2_aer / mwdry + ppm2ugkg(p_sulf) = 1.e+03_kind_phys * mw_so4_aer / mwdry + + ! -- initialize large-sacle wet depostion + if (ktau==1) then + call dep_wet_ls_init(data) + endif + + ! -- set control flags + + ! -- compute accumulated large-scale and convective rainfall since last call + if (ktau > 1) then + dtstep = call_chemistry * dt + else + dtstep = dt + end if + + ! -- compute incremental convective and large-scale rainfall + do i=its,ite + rcav(i,1)=max(rainc_cpl(i)*1000. , 0.) ! meter to mm + rnav(i,1)=max((rain_cpl(i)-rainc_cpl(i))*1000., 0.) ! meter to mm + enddo + +!!! + +!>- get ready for chemistry run + call rrfs_smoke_prep_lsdep(data,ktau,dtstep, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, dqdt, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,dqdti,z_at_w,vvel, & + ntsmoke,ntdust, & + ntrac,gq0,num_chem, num_moist, & + ppm2ugkg,moist,chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + + ! -- ls wet deposition + select case (wetdep_ls_opt) + case (WDLS_OPT_GSD) + call wetdep_ls(data,dt,chem,rnav,moist,rho_phy,var_rmv, & + num_moist,num_chem,p_qc,p_qi,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + case (WDLS_OPT_NGAC) + call WetRemovalGOCART(data,its,ite, jts,jte, kts,kte, 1,1, dt, & + num_chem,var_rmv,chem,p_phy,t_phy, & + rho_phy,dqdti,rcav,rnav, & + ims,ime, jms,jme, kms,kme) + !if (chem_rc_check(localrc, msg="Failure in NGAC wet removal scheme", & + ! file=__FILE__, line=__LINE__, rc=rc)) return + case default + ! -- no further option implemented + end select + + + ! -- put chem stuff back into tracer array + do k=kts,kte + do i=its,ite + gq0(i,k,ntsmoke)=ppm2ugkg(p_oc1 ) * max(epsilc,chem(i,k,1,p_oc1)) + gq0(i,k,ntdust )=ppm2ugkg(p_dust_1) * max(epsilc,chem(i,k,1,p_dust_1)) + enddo + enddo + + do k=kts,kte + do i=its,ite + qgrs(i,k,ntsmoke)=gq0(i,k,ntsmoke) + qgrs(i,k,ntdust )=gq0(i,k,ntdust ) + enddo + enddo + + +! + end subroutine rrfs_smoke_lsdep_wrapper_run +!> @} + + subroutine rrfs_smoke_prep_lsdep(data,ktau,dtstep, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,dqdti,z_at_w,vvel, & + ntsmoke,ntdust, & + ntrac,gq0,num_chem, num_moist, & + ppm2ugkg,moist,chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + implicit none + type(smoke_data), intent(inout) :: data + + !Chem input configuration + integer, intent(in) :: ktau + real(kind=kind_phys), intent(in) :: dtstep + + !FV3 input variables + integer, intent(in) :: ntrac,ntsmoke,ntdust + real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d + real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & + phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt + real(kind=kind_phys), dimension(ims:ime, kts:kte,ntrac), intent(in) :: gq0 + + + !GSD Chem variables + integer,intent(in) :: num_chem, num_moist + integer,intent(in) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + real(kind_phys), dimension(num_chem), intent(in) :: ppm2ugkg + + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: & + rri, t_phy, u_phy, v_phy, p_phy, rho_phy, dz8w, p8w, t8w, vvel, dqdti + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_moist), intent(out) :: moist + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_chem), intent(out) :: chem + + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w + + ! -- local variables +! real(kind=kind_phys), dimension(ims:ime, kms:kme, jms:jme) :: p_phy + real(kind_phys) :: factor,factor2,pu,pl,aln,pwant + real(kind_phys) :: xhour,xmin,xlonn,xtime,real_time + real(kind_phys), DIMENSION (1,1) :: sza,cosszax + integer i,ip,j,jp,k,kp,kk,kkp,nv,jmax,jmaxi,l,ll,n,ndystep,ixhour + + ! -- initialize output arrays + rri = 0._kind_phys + t_phy = 0._kind_phys + u_phy = 0._kind_phys + v_phy = 0._kind_phys + p_phy = 0._kind_phys + rho_phy = 0._kind_phys + dz8w = 0._kind_phys + p8w = 0._kind_phys + t8w = 0._kind_phys + vvel = 0._kind_phys + dqdti = 0._kind_phys + moist = 0._kind_phys + chem = 0._kind_phys + z_at_w = 0._kind_phys + + + do j=jts,jte + jp = j - jts + 1 + do i=its,ite + ip = i - its + 1 + z_at_w(i,kts,j)=max(0.,ph3d(ip,1)/g) + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=abs(ph3d(ip,kp+1)-ph3d(ip,kp))/g + z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + p8w(i,k,j)=pr3d(ip,kp) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kk=min(k,kte) + kkp = kk - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) + t_phy(i,k,j)=tk3d(ip,kkp) + p_phy(i,k,j)=prl3d(ip,kkp) + u_phy(i,k,j)=us3d(ip,kkp) + dqdti(i,k,j)=dqdt(ip,kkp) + v_phy(i,k,j)=vs3d(ip,kkp) + rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(ip,kkp))) + rri(i,k,j)=1./rho_phy(i,k,j) + vvel(i,k,j)=-w(ip,kkp)*rri(i,k,j)/g + moist(i,k,j,:)=0. + moist(i,k,j,1)=gq0(ip,kkp,p_atm_shum) + if (t_phy(i,k,j) > 265.) then + moist(i,k,j,2)=gq0(ip,kkp,p_atm_cldq) + moist(i,k,j,3)=0. + if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. + else + moist(i,k,j,2)=0. + moist(i,k,j,3)=gq0(ip,kkp,p_atm_cldq) + if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. + endif + !-- + enddo + enddo + enddo + + do j=jts,jte + do k=2,kte + do i=its,ite + t8w(i,k,j)=.5*(t_phy(i,k,j)+t_phy(i,k-1,j)) + enddo + enddo + enddo + + ! -- only used in phtolysis.... + do j=jts,jte + do i=its,ite + t8w(i,1,j)=t_phy(i,1,j) + t8w(i,kte+1,j)=t_phy(i,kte,j) + enddo + enddo + + + do k=kms,kte + do i=ims,ime + chem(i,k,jts,p_oc1 )=max(epsilc,gq0(i,k,ntsmoke)/ppm2ugkg(p_oc1)) + chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )/ppm2ugkg(p_dust_1)) + enddo + enddo + + + end subroutine rrfs_smoke_prep_lsdep +!> @} + end module rrfs_smoke_lsdep_wrapper diff --git a/smoke/rrfs_smoke_lsdep_wrapper.meta b/smoke/rrfs_smoke_lsdep_wrapper.meta new file mode 100755 index 000000000..7766ab2c4 --- /dev/null +++ b/smoke/rrfs_smoke_lsdep_wrapper.meta @@ -0,0 +1,210 @@ +[ccpp-table-properties] + name = rrfs_smoke_lsdep_wrapper + type = scheme + dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_lsdep_wrapper_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_lsdep_wrapper_finalize + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_lsdep_wrapper_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[kte] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[kme] + standard_name = vertical_interface_dimension + long_name = number of vertical levels plus one + units = count + dimensions = () + type = integer + intent = in +[ktau] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[dt] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[rain_cpl] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rainc_cpl] + standard_name = lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep + long_name = convective rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[pr3d] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[ph3d] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[phl3d] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prl3d] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[tk3d] + standard_name = air_temperature_of_new_state + long_name = updated temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[us3d] + standard_name = x_wind_of_new_state + long_name = updated x-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vs3d] + standard_name = y_wind_of_new_state + long_name = updated y-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[spechum] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[w] + standard_name = lagrangian_tendency_of_air_pressure + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dqdt] + standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection + long_name = instantaneous moisture tendency due to convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[ntsmoke] + standard_name = index_for_smoke + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[wetdep_ls_opt_in] + standard_name = rrfs_smoke_wetdep_ls_opt + long_name = rrfs smoke large scale wet deposition option + units = index + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/smoke/rrfs_smoke_postpbl.F90 b/smoke/rrfs_smoke_postpbl.F90 new file mode 100755 index 000000000..02ed273ae --- /dev/null +++ b/smoke/rrfs_smoke_postpbl.F90 @@ -0,0 +1,73 @@ +!>\file rrfs_smoke_postpbl.F90 +!! This file is CCPP RRFS smoke postpbl driver +!! Haiqin.Li@noaa.gov 03/2022 + + module rrfs_smoke_postpbl + + use machine , only : kind_phys + use rrfs_smoke_config + + implicit none + + private + + public :: rrfs_smoke_postpbl_init, rrfs_smoke_postpbl_run, rrfs_smoke_postpbl_finalize + +contains + +!> \brief Brief description of the subroutine +!! + subroutine rrfs_smoke_postpbl_init() + end subroutine rrfs_smoke_postpbl_init + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_rrfs_smoke_postpbl_finalize Argument Table +!! + subroutine rrfs_smoke_postpbl_finalize() + end subroutine rrfs_smoke_postpbl_finalize + +!> \defgroup gsd_chem_group GSD Chem emission driver Module +!! This is the gsd chemistry +!>\defgroup rrfs_smoke_postpbl GSD Chem emission driver Module +!> \ingroup gsd_chem_group +!! This is the GSD Chem emission driver Module +!! \section arg_table_rrfs_smoke_postpbl_run Argument Table +!! \htmlinclude rrfs_smoke_postpbl_run.html +!! +!>\section rrfs_smoke_postpbl GSD Chemistry Scheme General Algorithm +!> @{ + subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & + qgrs, chem3d, errmsg, errflg) + + implicit none + + + integer, intent(in) :: ite,kte,ntsmoke,ntdust,ntrac + + integer, parameter :: its=1,kts=1 + + real(kind_phys), dimension(ite,kte,ntrac), intent(inout) :: qgrs + real(kind_phys), dimension(ite,kte, 2), intent(inout) :: chem3d + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!>-- local variables + integer :: i, k + + errmsg = '' + errflg = 0 + + !--- put smoke stuff back into tracer array + + do k=kts,kte + do i=its,ite + qgrs(i,k,ntsmoke)= chem3d(i,k,1) + qgrs(i,k,ntdust )= chem3d(i,k,2) + enddo + enddo + + end subroutine rrfs_smoke_postpbl_run + +!> @} + end module rrfs_smoke_postpbl diff --git a/smoke/rrfs_smoke_postpbl.meta b/smoke/rrfs_smoke_postpbl.meta new file mode 100755 index 000000000..e9597adc8 --- /dev/null +++ b/smoke/rrfs_smoke_postpbl.meta @@ -0,0 +1,85 @@ +[ccpp-table-properties] + name = rrfs_smoke_wrapper + type = scheme + dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_finalize + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_run + type = scheme +[ite] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[kte] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntsmoke] + standard_name = index_for_smoke + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 new file mode 100755 index 000000000..7b2cda56b --- /dev/null +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -0,0 +1,762 @@ +!>\file rrfs_smoke_wrapper.F90 +!! This file is CCPP RRFS smoke driver +!! Haiqin.Li@noaa.gov 02/2021 + + module rrfs_smoke_wrapper + + use physcons, only : g => con_g, pi => con_pi + use machine , only : kind_phys + use rrfs_smoke_config + use dust_data_mod + use seas_mod, only : gocart_seasalt_driver + use dust_fengsha_mod,only : gocart_dust_fengsha_driver + use plume_data_mod + use module_plumerise1 !plume_rise_mod + use module_add_emiss_burn + use dep_dry_mod + use rrfs_smoke_data + + implicit none + + private + + public :: rrfs_smoke_wrapper_init, rrfs_smoke_wrapper_run, rrfs_smoke_wrapper_finalize + +contains + +!> \brief Brief description of the subroutine +!! + subroutine rrfs_smoke_wrapper_init() + end subroutine rrfs_smoke_wrapper_init + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_rrfs_smoke_wrapper_finalize Argument Table +!! + subroutine rrfs_smoke_wrapper_finalize() + end subroutine rrfs_smoke_wrapper_finalize + +!> \defgroup gsd_chem_group GSD Chem emission driver Module +!! This is the gsd chemistry +!>\defgroup rrfs_smoke_wrapper GSD Chem emission driver Module +!> \ingroup gsd_chem_group +!! This is the GSD Chem emission driver Module +!! \section arg_table_rrfs_smoke_wrapper_run Argument Table +!! \htmlinclude rrfs_smoke_wrapper_run.html +!! +!>\section rrfs_smoke_wrapper GSD Chemistry Scheme General Algorithm +!> @{ + subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, & + u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & + pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & + nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl,snow, & + julian, idat, rain_cpl, rainc_cpl, exch, hf2d, & + dust12m_in, emi_in, smoke_GBBEPx, ntrac, qgrs, gq0, chem3d, tile_num, & + ntsmoke, ntdust, imp_physics, imp_physics_thompson, & + nwfa, nifa, emanoc, & + emdust, emseas, ebb_smoke_hr, frp_hr, frp_std_hr, & + coef_bb, ebu_smoke,fhist, min_fplume, max_fplume, hwp, & + smoke_ext, dust_ext, & + seas_opt_in, dust_opt_in, biomass_burn_opt_in, drydep_opt_in, & + do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, & + smoke_forecast_in, aero_ind_fdb_in,dbg_opt_in,errmsg,errflg) + + implicit none + + + integer, intent(in) :: im,kte,kme,ktau,nsoil,tile_num,jdate(8),idat(8) + integer, intent(in) :: ntrac, ntsmoke, ntdust + real(kind_phys),intent(in) :: dt, julian + logical, intent(in) :: smoke_forecast_in,aero_ind_fdb_in,dbg_opt_in + + integer, parameter :: ids=1,jds=1,jde=1, kds=1 + integer, parameter :: ims=1,jms=1,jme=1, kms=1 + integer, parameter :: its=1,jts=1,jte=1, kts=1 + + integer, dimension(im), intent(in) :: land, vegtype, soiltyp + real(kind_phys), dimension(im,nsoil), intent(in) :: smc + real(kind_phys), dimension(im,12, 5), intent(in) :: dust12m_in + real(kind_phys), dimension(im,24, 3), intent(in) :: smoke_GBBEPx + real(kind_phys), dimension(im, 1), intent(in) :: emi_in + real(kind_phys), dimension(im), intent(in) :: u10m, v10m, ustar, dswsfc, & + garea, rlat,rlon, tskin, pb2d, sigmaf, zorl, snow, & + rain_cpl, rainc_cpl, hf2d, t2m, dpt2m + real(kind_phys), dimension(im,kme), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(im,kte), intent(in) :: phl3d, prl3d, tk3d, & + us3d, vs3d, spechum, exch, w + real(kind_phys), dimension(im,kte,ntrac), intent(inout) :: qgrs, gq0 + real(kind_phys), dimension(im,kte, 2), intent(inout) :: chem3d + real(kind_phys), dimension(im), intent(inout) :: emdust, emseas, emanoc + real(kind_phys), dimension(im), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr + real(kind_phys), dimension(im ), intent(inout) :: coef_bb, fhist + real(kind_phys), dimension(im,kte), intent(inout) :: ebu_smoke + real(kind_phys), dimension(im), intent(inout) :: max_fplume, min_fplume + real(kind_phys), dimension(im), intent( out) :: hwp + real(kind_phys), dimension(im,kte), intent(out) :: smoke_ext, dust_ext + real(kind_phys), dimension(im,kte), intent(inout) :: nwfa, nifa + integer, intent(in ) :: imp_physics, imp_physics_thompson + integer, intent(in) :: seas_opt_in, dust_opt_in, biomass_burn_opt_in, & + drydep_opt_in, plumerisefire_frq_in, addsmoke_flag_in + logical, intent(in ) :: do_plumerise_in + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: ebu + real(kind_phys), dimension(1:im, 1:kme,jms:jme) :: rri, t_phy, u_phy, v_phy, & + p_phy, z_at_w, dz8w, p8w, t8w, rho_phy, vvel, zmid, exch_h + + real(kind_phys), dimension(ims:im, jms:jme) :: u10, v10, ust, tsk, & + xland, xlat, xlong, dxy, pbl, hfx, rcav, rnav + +!>- sea salt & chemistry variables + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem + real(kind_phys), dimension(ims:im, 1, jms:jme, 1:num_emis_seas ) :: emis_seas + real(kind_phys), dimension(ims:im, jms:jme, 1:num_chem ) :: dry_fall + real(kind_phys), dimension(ims:im, jms:jme) :: seashelp + + integer :: ide, ime, ite, kde, julday + +!>- dust & chemistry variables + real(kind_phys), dimension(ims:im, jms:jme) :: ssm, rdrag, uthr, snowh ! fengsha dust + real(kind_phys), dimension(ims:im, jms:jme) :: vegfrac, rmol, swdown, znt, clayf, sandf + real(kind_phys), dimension(ims:im, nsoil, jms:jme) :: smois + real(kind_phys), dimension(ims:im, 1:1, jms:jme, 1:num_emis_dust) :: emis_dust + integer, dimension(ims:im, jms:jme) :: isltyp, ivgtyp + +!>- plume variables + ! -- buffers + real(kind_phys), dimension(ims:im, jms:jme) :: ebu_in + real(kind_phys), dimension(ims:im, jms:jme, num_frp_plume ) :: plume_frp + real(kind_phys), dimension(ims:im, jms:jme ) :: coef_bb_dc, flam_frac, & + fire_hist, peak_hr + real(kind_phys), dimension(ims:im,kms:kme,jms:jme ) :: aod3d_smoke, aod3d_dust + integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2 + real(kind_phys) :: dtstep + logical :: call_plume, scale_fire_emiss +!>- optical variables + real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: rel_hum + +!>-- anthropogentic variables +! real(kind_phys), dimension(ims:im, kms:kemit, jms:jme, 1:num_emis_ant) :: emis_ant + real(kind_phys), dimension(ims:im) :: emis_anoc + + real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: ac3, ahno3, anh3, asulf, cor3, h2oai, h2oaj, nu3 + real(kind_phys), dimension(ims:im, jms:jme) :: dep_vel_o3, e_co + + real(kind_phys) :: gmt + real(kind_phys), dimension(1:num_chem) :: ppm2ugkg + +!> -- parameter to caluclate wfa&ifa (m) + real(kind_phys), parameter :: mean_diameter1= 4.E-8, sigma1=1.8 + real(kind_phys), parameter :: mean_diameter2= 1.E-6, sigma2=1.8 + real(kind_phys), parameter :: kappa_oc = 0.2 + real(kind_phys), parameter :: kappa_dust = 0.04 + real(kind_phys), parameter :: fact_wfa = 1.e-9*6.0/pi*exp(4.5*log(sigma1)**2)/mean_diameter1**3 + real(kind_phys), parameter :: fact_ifa = 1.e-9*6.0/pi*exp(4.5*log(sigma2)**2)/mean_diameter2**3 +!> -- aerosol density (kg/m3) + real(kind_phys), parameter :: density_dust= 2.6e+3, density_sulfate=1.8e+3 + real(kind_phys), parameter :: density_oc = 1.4e+3, density_seasalt=2.2e+3 + + real(kind_phys) :: daero_emis_wfa, daero_emis_ifa +!>-- local variables + real(kind_phys), dimension(im) :: wdgust, snoweq + integer :: current_month, current_hour + real(kind_phys) :: curr_secs + real(kind_phys) :: factor, factor2, factor3 + integer :: nbegin, nv, nvv + integer :: i, j, jp, k, kp, n + + type(smoke_data), pointer :: data + + data => get_thread_smoke_data() + + errmsg = '' + errflg = 0 + +!>-- options to turn on/off sea-salt, dust, plume-rising + seas_opt = seas_opt_in + dust_opt = dust_opt_in + biomass_burn_opt = biomass_burn_opt_in + drydep_opt = drydep_opt_in + do_plumerise = do_plumerise_in + plumerisefire_frq = plumerisefire_frq_in + addsmoke_flag = addsmoke_flag_in + smoke_forecast = smoke_forecast_in + aero_ind_fdb = aero_ind_fdb_in + dbg_opt = dbg_opt_in + + !print*,'hli ktau',ktau + ! -- set domain + ide=im + ime=im + ite=im + kde=kte + + h2oai = 0. + h2oaj = 0. + nu3 = 0. + ac3 = 0. + cor3 = 0. + asulf = 0. + ahno3 = 0. + anh3 = 0. + e_co = 0. + dep_vel_o3 = 0. + + min_fplume2 = 0 + max_fplume2 = 0 + emis_seas = 0. + emis_dust = 0. + peak_hr = 0. + flam_frac = 0. + aod3d_smoke = 0. + aod3d_dust = 0. + + rcav = 0. + rnav = 0. + + curr_secs = ktau * dt + current_month=jdate(2) + current_hour =jdate(5)+1 + gmt = real(idat(5)) + julday = int(julian) + + ! -- volume to mass fraction conversion table (ppm -> ug/kg) + ppm2ugkg = 1._kind_phys + ppm2ugkg(p_sulf) = 1.e+03_kind_phys * mw_so4_aer / mwdry + + ! -- compute incremental convective and large-scale rainfall + do i=its,ite + rcav(i,1)=max(rainc_cpl(i)*1000. , 0.) ! meter to mm + rnav(i,1)=max((rain_cpl(i)-rainc_cpl(i))*1000., 0.) ! meter to mm + coef_bb_dc(i,1) = coef_bb(i) + fire_hist (i,1) = fhist (i) + enddo + + + ! plumerise frequency in minutes set up by the namelist input + call_plume = (biomass_burn_opt == BURN_OPT_ENABLE) .and. (plumerisefire_frq > 0) + if (call_plume) & + call_plume = (mod(int(curr_secs), max(1, 60*plumerisefire_frq)) == 0) & + .or. (ktau == 2) + + !scale_fire_emiss = .false. + + ! -- compute accumulated large-scale and convective rainfall since last call + if (ktau > 1) then + dtstep = call_chemistry * dt + else + dtstep = dt + end if + +!>- get ready for chemistry run + call rrfs_smoke_prep( & + ktau, current_month, current_hour, & + u10m,v10m,ustar,land,garea,rlat,rlon,tskin, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & + nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & + snow,dust12m_in,emi_in,smoke_GBBEPx, & + hf2d, pb2d, & + u10,v10,ust,tsk,xland,xlat,xlong,dxy, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,exch_h, & + z_at_w,vvel,zmid, & + ntrac,gq0, & + num_chem, num_moist, ppm2ugkg, & + ntsmoke, ntdust, & + moist,chem,plume_frp,ebu_in, & + ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & + smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & + snowh,clayf,rdrag,sandf,ssm,uthr,rel_hum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + +! Make this global, calculate at 1st time step only +!>-- for plumerise -- +!IF (ktau==1) THEN + do j=jts,jte + do i=its,ite + if (xlong(i,j)<-130.) then + peak_hr(i,j)= 0.0* 3600. ! peak at 24 UTC, fires in Alaska + elseif(xlong(i,j)<-115.) then + peak_hr(i,j)= 23.0* 3600. + elseif (xlong(i,j)<-100.) then + peak_hr(i,j)= 22.0* 3600. ! peak at 22 UTC, fires in the western US + elseif (xlong(i,j)<-85.) then + peak_hr(i,j)= 21.0* 3600. + elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in the eastern US + peak_hr(i,j)= 20.0* 3600. + else + peak_hr(i,j)= 19.0* 3600. + endif + enddo + enddo +!END IF + + IF (ktau==1) THEN + ebu = 0. + do j=jts,jte + do i=its,ite + ebu(i,kts,j)= ebu_in(i,j) + do k=kts+1,kte + ebu(i,k,j)= 0. + enddo + enddo + enddo + ELSE + do k=kts,kte + do i=its,ite + ebu(i,k,1)=ebu_smoke(i,k) + enddo + enddo + ENDIF + + +!>- compute sea-salt + ! -- compute sea salt + if (seas_opt >= SEAS_OPT_DEFAULT) then + call gocart_seasalt_driver(ktau,dt,rri,t_phy,moist, & + u_phy,v_phy,chem,rho_phy,dz8w,u10,v10,ust,p8w,tsk, & + xland,xlat,xlong,dxy,g,emis_seas, & + seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + endif + + !-- compute dust + select case (dust_opt) + case (DUST_OPT_FENGSHA) + ! Set at compile time in dust_data_mod: + call gocart_dust_fengsha_driver(data,dt,chem,rho_phy,smois,p8w,ssm, & + isltyp,vegfrac,snowh,xland,dxy,g,emis_dust,ust,znt, & + clayf,sandf,rdrag,uthr, & + num_emis_dust,num_moist,num_chem,nsoil, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + end select + + ! compute wild-fire plumes + !-- to add a namelist option to turn on/off plume raising + !--- replace plumerise_driver with HRRR-smoke 05/10/2021 + !-- /scratch2/BMC/ap-fc/Ravan/rapid-refresh/WRFV3.9/smoke + ! Every hour (per namelist) the ebu_driver is called to calculate ebu, but + ! the plumerise is controlled by the namelist option of plumerise_flag + if (call_plume) then +! WRITE(*,*) 'plumerise is called at ktau= ',ktau + call ebu_driver ( & + data,flam_frac,ebu_in,ebu, & + t_phy,moist(:,:,:,p_qv), & + rho_phy,vvel,u_phy,v_phy,p_phy, & + z_at_w,zmid,ktau, & + plume_frp, min_fplume2, max_fplume2, & ! new approach + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + end if + + ! -- add biomass burning emissions at every timestep + if (addsmoke_flag == 1) then + call add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum,chem, & + julday,gmt,xlat,xlong, & + ivgtyp, vegfrac, peak_hr, & ! RAR + curr_secs,ebu, & + coef_bb_dc,fire_hist,aod3d_smoke,aod3d_dust, & + ! scalar(ims,kms,jms,P_QNWFA),scalar(ims,kms,jms,P_QNIFA), ! & + rcav, rnav,swdown,smoke_forecast, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif +! WRITE(*,*) 'after add_emis_burn at ktau= ',ktau + + !>-- compute dry deposition + if (drydep_opt == 1) then + call dry_dep_driver(data,ktau,dt,julday,current_month,t_phy,p_phy, & + moist,p8w,rmol,rri,gmt,t8w,rcav, & + chem,rho_phy,dz8w,exch_h,hfx, & + ivgtyp,tsk,swdown,vegfrac,pbl,ust,znt,zmid,z_at_w, & + xland,xlat,xlong,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & + anh3,dry_fall,dep_vel_o3,g, & + e_co,kemit,snowh,numgas, & + num_chem,num_moist, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + endif +! WRITE(*,*) 'dry depostion is done at ktau= ',ktau + + do k=kts,kte + do i=its,ite + ebu_smoke(i,k)=ebu(i,k,1) + enddo + enddo + + +!---- diagnostic output of hourly wildfire potential (07/2021) + hwp = 0. + do i=its,ite + wdgust(i)=1.68*sqrt(us3d(i,1)**2+vs3d(i,1)**2) + snoweq(i)=max((25.-snow(i)*1000.)/25.,0.) + !hwp(i)=44.09*wdgust(i)**1.82*max(0.,t2m(i)-dpt2m(i))**0.61*max(0.,1.-smc(i,1))**14.0*snoweq(i)*sigmaf(i) + hwp(i)=44.09*wdgust(i)**1.82*(t2m(i)-dpt2m(i))**0.61*(1.-smc(i,1))**14.0*snoweq(i)*sigmaf(i) + enddo + +!---- diagnostic output of smoke & dust optical extinction (12/2021) + do k=kts,kte + do i=its,ite + smoke_ext(i,k) = aod3d_smoke(i,k,1) + dust_ext (i,k) = aod3d_dust (i,k,1) + enddo + enddo +!------------------------------------- +!---- put smoke stuff back into tracer array + do k=kts,kte + do i=its,ite + gq0(i,k,ntsmoke )=ppm2ugkg(p_smoke ) * max(epsilc,chem(i,k,1,p_smoke)) ! + gq0(i,k,ntdust )=ppm2ugkg(p_dust_1) * max(epsilc,chem(i,k,1,p_dust_1)) + enddo + enddo + + do k=kts,kte + do i=its,ite + qgrs(i,k,ntsmoke )= gq0(i,k,ntsmoke ) + qgrs(i,k,ntdust )= gq0(i,k,ntdust ) + chem3d(i,k,1 )= gq0(i,k,ntsmoke ) + chem3d(i,k,2 )= gq0(i,k,ntdust ) + enddo + enddo +!------------------------------------- +!-- to output for diagnostics +! WRITE(*,*) 'rrfs nwfa/nifa 1 at ktau= ',ktau + do i = 1, im + emseas (i) = emis_seas (i,1,1,1)*1.e+9 ! size bin 1 sea salt emission: ug/m2/s + emdust (i) = emis_dust (i,1,1,1) ! size bin 1 dust emission : ug/m2/s + emanoc (i) = emis_anoc (i) ! anthropogenic organic carbon: ug/m2/s + coef_bb (i) = coef_bb_dc (i,1) + fhist (i) = fire_hist (i,1) + min_fplume (i) = real(min_fplume2(i,1)) + max_fplume (i) = real(max_fplume2(i,1)) + enddo + +! WRITE(*,*) 'rrfs nwfa/nifa 2 at ktau= ',ktau +!-- to provide real aerosol emission for Thompson MP + if (imp_physics == imp_physics_thompson .and. aero_ind_fdb) then + + do i = its, ite + do k = kts, kte + if (k==1)then + daero_emis_wfa =(emanoc(i)+ebu_smoke(i,k))/density_oc + emseas(i)/density_seasalt + else + daero_emis_wfa = ebu_smoke(i,k)/density_oc + endif + daero_emis_wfa = kappa_oc* daero_emis_wfa*fact_wfa*rri(i,k,1)/dz8w(i,k,1) ! consider using dust tracer + + nwfa(i,k) = nwfa(i,k) + daero_emis_wfa*dt + nifa(i,k) = gq0(i,k,ntdust)/density_dust*fact_ifa*kappa_dust ! Check the formula + + if(land(i).eq.1)then + nwfa(i,k) = nwfa(i,k)*(1 - 0.10*dt/86400.) !-- mimicking dry deposition + else + nwfa(i,k) = nwfa(i,k)*(1 - 0.05*dt/86400.) !-- mimicking dry deposition + endif + enddo + enddo + endif +! WRITE(*,*) 'rrfs smoke wrapper is done at ktau= ',ktau + + end subroutine rrfs_smoke_wrapper_run + + subroutine rrfs_smoke_prep( & + ktau,current_month,current_hour, & + u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & + nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & + snow_cpl,dust12m_in,emi_in,smoke_GBBEPx, & + hf2d, pb2d, & + u10,v10,ust,tsk,xland,xlat,xlong,dxy, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,exch_h, & + z_at_w,vvel,zmid, & + ntrac,gq0, & + num_chem, num_moist, ppm2ugkg, & + ntsmoke, ntdust, & + !num_emis_ant, & + !emis_ant, & + moist,chem,plume_frp,ebu_in, & + ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & + smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & + snowh,clayf,rdrag,sandf,ssm,uthr,rel_hum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + + !Chem input configuration + integer, intent(in) :: ktau, current_month, current_hour + + !FV3 input variables + integer, intent(in) :: nsoil + integer, dimension(ims:ime), intent(in) :: land, vegtype, soiltyp + integer, intent(in) :: ntrac + real(kind=kind_phys), dimension(ims:ime), intent(in) :: & + u10m, v10m, ustar, garea, rlat, rlon, ts2d, sigmaf, dswsfc, & + zorl, snow_cpl, pb2d, hf2d + real(kind=kind_phys), dimension(ims:ime, nsoil), intent(in) :: smc + real(kind=kind_phys), dimension(ims:ime, 12, 5), intent(in) :: dust12m_in + real(kind=kind_phys), dimension(ims:ime, 24, 3), intent(in) :: smoke_GBBEPx + real(kind=kind_phys), dimension(ims:ime, 1), intent(in) :: emi_in + real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d + real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & + phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w + real(kind=kind_phys), dimension(ims:ime, kts:kte,ntrac), intent(in) :: gq0 + + + !GSD Chem variables + !integer,intent(in) :: num_emis_ant + integer,intent(in) :: num_chem, num_moist, ntsmoke, ntdust + integer,intent(in) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + + !real(kind_phys), dimension(ims:ime, kms:kemit, jms:jme, num_emis_ant), intent(inout) :: emis_ant + real(kind_phys), dimension(num_chem), intent(in) :: ppm2ugkg + real(kind_phys), dimension(ims:ime, jms:jme),intent(out) :: ebu_in + real(kind_phys), dimension(ims:ime, jms:jme, num_frp_plume), intent(out) :: plume_frp + + integer,dimension(ims:ime, jms:jme), intent(out) :: isltyp, ivgtyp + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: & + rri, t_phy, u_phy, v_phy, p_phy, rho_phy, dz8w, p8w, t8w, vvel, & + zmid, exch_h, rel_hum + real(kind_phys), dimension(ims:ime, jms:jme), intent(out) :: & + u10, v10, ust, tsk, xland, xlat, xlong, dxy, vegfrac, rmol, swdown, znt, & + pbl, hfx, snowh, clayf, rdrag, sandf, ssm, uthr + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_moist), intent(out) :: moist + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_chem), intent(out) :: chem + + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w + real(kind_phys), dimension(ims:ime, nsoil, jms:jme), intent(out) :: smois + real(kind_phys), dimension(ims:ime), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr + real(kind_phys), dimension(ims:ime), intent(inout) :: emis_anoc + !real(kind_phys), dimension(ims:ime, jms:jme, num_plume_data) :: plume + real(kind_phys), parameter :: conv_frp = 1.e+06_kind_phys ! FRP conversion factor, MW to W + real(kind_phys), parameter :: frpc = 1._kind_phys ! FRP conversion factor (Regional) + + ! -- local variables + integer i,ip,j,jp,k,kp,kk,kkp,nv,l,ll,n + + ! -- initialize fire emissions + !plume = 0._kind_phys + plume_frp = 0._kind_phys + ebu_in = 0._kind_phys + ebb_smoke_hr = 0._kind_phys + emis_anoc = 0._kind_phys + + ! -- initialize output arrays + isltyp = 0._kind_phys + ivgtyp = 0._kind_phys + rri = 0._kind_phys + t_phy = 0._kind_phys + u_phy = 0._kind_phys + v_phy = 0._kind_phys + p_phy = 0._kind_phys + rho_phy = 0._kind_phys + dz8w = 0._kind_phys + p8w = 0._kind_phys + t8w = 0._kind_phys + vvel = 0._kind_phys + zmid = 0._kind_phys + exch_h = 0._kind_phys + u10 = 0._kind_phys + v10 = 0._kind_phys + ust = 0._kind_phys + tsk = 0._kind_phys + xland = 0._kind_phys + xlat = 0._kind_phys + xlong = 0._kind_phys + dxy = 0._kind_phys + vegfrac = 0._kind_phys + rmol = 0._kind_phys + swdown = 0._kind_phys + znt = 0._kind_phys + hfx = 0._kind_phys + pbl = 0._kind_phys + snowh = 0._kind_phys + clayf = 0._kind_phys + rdrag = 0._kind_phys + sandf = 0._kind_phys + ssm = 0._kind_phys + uthr = 0._kind_phys + moist = 0._kind_phys + chem = 0._kind_phys + z_at_w = 0._kind_phys + rel_hum = 0._kind_phys + + do i=its,ite + u10 (i,1)=u10m (i) + v10 (i,1)=v10m (i) + tsk (i,1)=ts2d (i) + ust (i,1)=ustar(i) + dxy (i,1)=garea(i) + xland(i,1)=real(land(i)) + xlat (i,1)=rlat(i)*180./pi + xlong(i,1)=rlon(i)*180./pi + swdown(i,1)=dswsfc(i) + znt (i,1)=zorl(i)*0.01 + hfx (i,1)=hf2d(i) + pbl (i,1)=pb2d(i) + snowh(i,1)=snow_cpl(i)*0.001 + clayf(i,1)=dust12m_in(i,current_month,1) + rdrag(i,1)=dust12m_in(i,current_month,2) + sandf(i,1)=dust12m_in(i,current_month,3) + ssm (i,1)=dust12m_in(i,current_month,4) + uthr (i,1)=dust12m_in(i,current_month,5) + ivgtyp (i,1)=vegtype(i) + isltyp (i,1)=soiltyp(i) + vegfrac(i,1)=sigmaf (i) + enddo + + rmol=0. + + do k=1,nsoil + do j=jts,jte + do i=its,ite + smois(i,k,j)=smc(i,k) + enddo + enddo + enddo + + !if (ktau <= 1) then + ! emis_ant = 0. + ! !emis_vol = 0. + !end if + + do j=jts,jte + jp = j - jts + 1 + do i=its,ite + ip = i - its + 1 + z_at_w(i,kts,j)=max(0.,ph3d(ip,1)/g) + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=abs(ph3d(ip,kp+1)-ph3d(ip,kp))/g + z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + p8w(i,k,j)=pr3d(ip,kp) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kk=min(k,kte) + kkp = kk - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) + t_phy(i,k,j)=tk3d(ip,kkp) + p_phy(i,k,j)=prl3d(ip,kkp) + u_phy(i,k,j)=us3d(ip,kkp) + v_phy(i,k,j)=vs3d(ip,kkp) + rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(ip,kkp))) + rri(i,k,j)=1./rho_phy(i,k,j) + vvel(i,k,j)=-w(ip,kkp)*rri(i,k,j)/g + moist(i,k,j,:)=0. + moist(i,k,j,1)=gq0(ip,kkp,p_atm_shum) + if (t_phy(i,k,j) > 265.) then + moist(i,k,j,2)=gq0(ip,kkp,p_atm_cldq) + moist(i,k,j,3)=0. + if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. + else + moist(i,k,j,2)=0. + moist(i,k,j,3)=gq0(ip,kkp,p_atm_cldq) + if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. + endif + rel_hum(i,k,j) = .95 + rel_hum(i,k,j) = MIN( .95, moist(i,k,j,1) / & + (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & + (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) + rel_hum(i,k,j)=max(0.1,rel_hum(i,k,j)) + !-- + zmid(i,k,j)=phl3d(ip,kkp)/g + enddo + enddo + enddo + + ! -- the imported atmospheric heat diffusivity is only available up to kte-1 + do k=kts,kte-1 + do i=its,ite + exch_h(i,k,1)=exch(i,k) + enddo + enddo + + do j=jts,jte + do k=2,kte + do i=its,ite + t8w(i,k,j)=.5*(t_phy(i,k,j)+t_phy(i,k-1,j)) + enddo + enddo + enddo + + ! -- only used in phtolysis.... + do j=jts,jte + do i=its,ite + t8w(i,1,j)=t_phy(i,1,j) + t8w(i,kte+1,j)=t_phy(i,kte,j) + enddo + enddo + + ! -- anthropogenic organic carbon + do i=its,ite + emis_anoc(i) = emi_in(i,1) + enddo + + ! select case (plumerise_flag) + ! case (FIRE_OPT_GBBEPx) + do j=jts,jte + do i=its,ite + ebb_smoke_hr(i) = smoke_GBBEPx(i,current_hour,1) ! smoke + frp_hr (i) = smoke_GBBEPx(i,current_hour,2) ! frp + frp_std_hr (i) = smoke_GBBEPx(i,current_hour,3) ! std frp + ebu_in (i,j) = ebb_smoke_hr(i) + plume_frp(i,j,p_frp_hr ) = conv_frp* frp_hr (i) + plume_frp(i,j,p_frp_std ) = conv_frp* frp_std_hr (i) + enddo + enddo + ! case default + ! end select + + ! We will add a namelist variable, real :: flam_frac_global + + do k=kms,kte + do i=ims,ime + chem(i,k,jts,p_smoke )=max(epsilc,gq0(i,k,ntsmoke )/ppm2ugkg(p_smoke)) + chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )/ppm2ugkg(p_dust_1)) + enddo + enddo + + + + end subroutine rrfs_smoke_prep + +!> @} + end module rrfs_smoke_wrapper diff --git a/smoke/rrfs_smoke_wrapper.meta b/smoke/rrfs_smoke_wrapper.meta new file mode 100755 index 000000000..867550f50 --- /dev/null +++ b/smoke/rrfs_smoke_wrapper.meta @@ -0,0 +1,632 @@ +[ccpp-table-properties] + name = rrfs_smoke_wrapper + type = scheme + dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_finalize + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[kte] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[kme] + standard_name = vertical_interface_dimension + long_name = number of vertical levels plus one + units = count + dimensions = () + type = integer + intent = in +[ktau] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[dt] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[garea] + standard_name = cell_area + long_name = grid cell area + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[land] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[jdate] + standard_name = date_and_time_of_forecast_in_united_states_order + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in +[u10m] + standard_name = x_wind_at_10m + long_name = 10 meter u wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[v10m] + standard_name = y_wind_at_10m + long_name = 10 meter v wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ustar] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tskin] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[pb2d] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[t2m] + standard_name = air_temperature_at_2m + long_name = 2 meter temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dpt2m] + standard_name = dewpoint_temperature_at_2m + long_name = 2 meter dewpoint temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[pr3d] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[ph3d] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[phl3d] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prl3d] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[tk3d] + standard_name = air_temperature_of_new_state + long_name = updated temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[us3d] + standard_name = x_wind_of_new_state + long_name = updated x-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vs3d] + standard_name = y_wind_of_new_state + long_name = updated y-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[spechum] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[w] + standard_name = lagrangian_tendency_of_air_pressure + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[nsoil] + standard_name = vertical_dimension_of_soil + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[smc] + standard_name = volume_fraction_of_condensed_water_in_soil + long_name = volumetric fraction of soil moisture + units = frac + dimensions = (horizontal_loop_extent,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[soiltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dswsfc] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length in cm + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[snow] + standard_name = lwe_thickness_of_snow_amount + long_name = snow fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[julian] + standard_name = forecast_julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = in +[idat] + standard_name = date_and_time_at_model_initialization_in_iso_order + long_name = initialization date and time + units = none + dimensions = (8) + type = integer + intent = in +[rain_cpl] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rainc_cpl] + standard_name = lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep + long_name = convective rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[exch] + standard_name = atmosphere_heat_diffusivity + long_name = diffusivity for heat + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[hf2d] + standard_name = instantaneous_surface_upward_sensible_heat_flux + long_name = surface upward sensible heat flux valid for current call + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dust12m_in] + standard_name = fengsha_dust12m_input + long_name = fengsha dust input + units = various + dimensions = (horizontal_loop_extent,12,5) + type = real + kind = kind_phys + intent = in +[emi_in] + standard_name = anthropogenic_background_input + long_name = anthropogenic background input + units = various + dimensions = (horizontal_loop_extent,1) + type = real + kind = kind_phys + intent = in +[smoke_GBBEPx] + standard_name = emission_smoke_GBBEPx + long_name = emission fire GBBEPx + units = various + dimensions = (horizontal_loop_extent,24,3) + type = real + kind = kind_phys + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + type = real + kind = kind_phys + intent = inout +[tile_num] + standard_name = index_of_cubed_sphere_tile + long_name = tile number + units = none + dimensions = () + type = integer + intent = in +[ntsmoke] + standard_name = index_for_smoke + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_thompson] + standard_name = identifier_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[nwfa] + standard_name = mass_number_concentration_of_hygroscopic_aerosols_of_new_state + long_name = number concentration of water-friendly aerosols + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[nifa] + standard_name = mass_number_concentration_of_nonhygroscopic_ice_nucleating_aerosols_of_new_state + long_name = number concentration of ice-friendly aerosols + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[emanoc] + standard_name = emission_of_anoc_for_thompson_mp + long_name = emission of anoc for thompson mp + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[emdust] + standard_name = emission_of_dust_for_smoke + long_name = emission of dust for smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[emseas] + standard_name = emission_of_seas_for_smoke + long_name = emission of seas for smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ebb_smoke_hr] + standard_name = surfce_emission_of_smoke + long_name = emission of surface smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[frp_hr] + standard_name = frp_hourly + long_name = hourly frp + units = mw + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[frp_std_hr] + standard_name = frp_std_hourly + long_name = hourly std frp + units = mw + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[coef_bb] + standard_name = coef_bb_dc + long_name = coef bb dc from plumerise + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ebu_smoke] + standard_name = ebu_smoke + long_name = smoke buffer of ebu + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[fhist] + standard_name = fhist + long_name = fire hist + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[min_fplume] + standard_name = min_fplume + long_name = miminum plume height + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[max_fplume] + standard_name = max_fplume + long_name = maximum plume height + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[hwp] + standard_name = rrfs_hwp + long_name = rrfs hourly fire weather potential + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[smoke_ext] + standard_name = smoke_ext + long_name = smoke optical extinction + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dust_ext] + standard_name = dust_ext + long_name = dust optical extinction + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[seas_opt_in] + standard_name = rrfs_smoke_sea_salt_opt + long_name = rrfs smoke sea salt emission option + units = index + dimensions = () + type = integer + intent = in +[dust_opt_in] + standard_name = rrfs_smoke_dust_opt + long_name = rrfs smoke dust chem option + units = index + dimensions = () + type = integer + intent = in +[biomass_burn_opt_in] + standard_name = rrfs_smoke_biomass_burn_opt + long_name = rrfs smoke biomass burning option + units = index + dimensions = () + type = integer + intent = in +[drydep_opt_in] + standard_name = rrfs_smoke_drydep_opt + long_name = rrfs smoke dry deposition option + units = index + dimensions = () + type = integer + intent = in +[do_plumerise_in] + standard_name = rrfs_smoke_plumerise_flag + long_name = rrfs smoke plumerise option + units = index + dimensions = () + type = logical + intent = in +[plumerisefire_frq_in] + standard_name = rrfs_smoke_plumerisefire_frq + long_name = rrfs smoke add smoke option + units = index + dimensions = () + type = integer + intent = in +[addsmoke_flag_in] + standard_name = rrfs_smoke_addsmoke_flag + long_name = rrfs smoke add smoke option + units = index + dimensions = () + type = integer + intent = in +[smoke_forecast_in] + standard_name = rrfs_smoke_smoke_forecast_opt + long_name = flag for rrfs smoke forecast + units = flag + dimensions = () + type = logical + intent = in +[aero_ind_fdb_in] + standard_name = rrfs_smoke_aero_ind_fdb_opt + long_name = flag for rrfs wfa ifa emission + units = flag + dimensions = () + type = logical + intent = in +[dbg_opt_in] + standard_name = rrfs_smoke_plumerise_debug + long_name = flag for rrfs smoke plumerise debug + units = flag + dimensions = () + type = logical + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/smoke/seas_data_mod.F90 b/smoke/seas_data_mod.F90 new file mode 100755 index 000000000..6602d58a2 --- /dev/null +++ b/smoke/seas_data_mod.F90 @@ -0,0 +1,18 @@ +module seas_data_mod + + use machine , only : kind_phys + + ! -- parameters from NGAC v2.4.0 (rev. d48932c) + integer, parameter :: number_ss_bins = 5 + ! -- lower/upper particle radii (um) for each bin + real(kind=kind_phys), dimension(number_ss_bins), parameter :: ra = (/ 0.03, 0.1, 0.5, 1.5, 5.0 /) + real(kind=kind_phys), dimension(number_ss_bins), parameter :: rb = (/ 0.1, 0.5, 1.5, 5.0, 10.0 /) + ! -- global scaling factors for sea salt emissions (originally 0.875 in NGAC namelist) + !real(kind=kind_phys), dimension(number_ss_bins), parameter :: emission_scale = (/ 0.100, 0.100, 0.100, 0.100, 0.100 /) + real(kind=kind_phys), dimension(number_ss_bins), parameter :: emission_scale = (/ 1.0, 1.0, 1.0, 1.0, 1.0 /) + ! -- sea salt density + real(kind=kind_phys), dimension(number_ss_bins), parameter :: den_seas = (/ 2200., 2200., 2200., 2200., 2200. /) + ! -- particle effective radius (m) + real(kind=kind_phys), dimension(number_ss_bins), parameter :: reff_seas = (/ 0.079e-6, 0.316e-6, 1.119e-6, 2.818e-6, 7.772e-6 /) + +end module seas_data_mod diff --git a/smoke/seas_mod.F90 b/smoke/seas_mod.F90 new file mode 100755 index 000000000..a610884d6 --- /dev/null +++ b/smoke/seas_mod.F90 @@ -0,0 +1,429 @@ +module seas_mod + + use machine , only : kind_phys + use physcons, only : pi=>con_pi +! use chem_rc_mod, only : chem_rc_test +! use chem_tracers_mod, only : p_seas_1, p_seas_2, p_seas_3, p_seas_4, p_seas_5, & +! p_eseas1, p_eseas2, p_eseas3, p_eseas4, p_eseas5, & +! config => chem_config + use seas_data_mod + use seas_ngac_mod + + implicit none + + integer, parameter :: SEAS_OPT_DEFAULT = 1 + integer, parameter :: CHEM_OPT_GOCART = 300 + integer, parameter :: chem_opt = 300 + + ! -- NGAC parameters + integer, parameter :: emission_scheme = 3 ! GEOSS 2012 + + private + + public :: SEAS_OPT_DEFAULT + + public :: gocart_seasalt_driver + +CONTAINS + + subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & + v_phy,chem,rho_phy,dz8w,u10,v10,ustar,p8w,tsk, & + xland,xlat,xlong,area,g,emis_seas, & + seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + INTEGER, INTENT(IN ) :: ktau,num_emis_seas,num_moist,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte,seas_opt + REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL(kind=kind_phys), DIMENSION( ims:ime, 1, jms:jme,num_emis_seas), & + INTENT(OUT ) :: & + emis_seas + REAL(kind=kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + u10, & + v10, & + ustar,tsk, & + xland, & + xlat, & + xlong,area + REAL(kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & + INTENT(OUT ) :: seashelp + REAL(kind=kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + alt, & + t_phy, & + dz8w,p8w, & + u_phy,v_phy,rho_phy + + REAL(kind=kind_phys), INTENT(IN ) :: dt,g +! + integer, parameter :: p_seas_1=15 + integer, parameter :: p_seas_2=16 + integer, parameter :: p_seas_3=17 + integer, parameter :: p_seas_4=18 + integer, parameter :: p_seas_5=19 + + integer, parameter :: p_eseas1=1 + integer, parameter :: p_eseas2=2 + integer, parameter :: p_eseas3=3 + integer, parameter :: p_eseas4=4 + integer, parameter :: p_eseas5=5 +! +! local variables +! + integer :: ipr,i,j,imx,jmx,lmx,n,rc,chem_config + integer,dimension (1,1) :: ilwi + real(kind=kind_phys) :: fsstemis, memissions, nemissions, tskin_c, ws10m + real(kind=kind_phys) :: delp + real(kind=kind_phys), DIMENSION (number_ss_bins) :: tc,bems + real(kind=kind_phys), dimension (1,1) ::w10m,airmas,tskin + real(kind=kind_phys), dimension (1) :: dxy + + real(kind=kind_phys), dimension(1,1,1) :: airmas1 + real(kind=kind_phys), dimension(1,1,1,number_ss_bins) :: tc1 + real(kind=kind_phys), dimension(1,1,number_ss_bins) :: bems1 + +! +! local parameters +! + real(kind=kind_phys), parameter :: conver = 1.e-9_kind_phys + real(kind=kind_phys), parameter :: converi = 1.e+9_kind_phys +! +! number of dust bins +! + imx=1 + jmx=1 + lmx=1 + + chem_config=CHEM_OPT_GOCART + + emis_seas = 0. + +! select case (config % chem_opt) + select case (chem_opt) + + case (304, 316, 317) + + seashelp(:,:)=0. + do j=jts,jte + do i=its,ite +! +! don't do dust over water!!! +! + if(xland(i,j).lt.0.5)then + ilwi(1,1)=0 + tc(1)=chem(i,kts,j,p_seas_1)*conver + tc(2)=1.e-30_kind_phys + tc(3)=chem(i,kts,j,p_seas_2)*conver + tc(4)=1.e-30_kind_phys + w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) + tskin(1,1)=tsk(i,j) + delp = p8w(i,kts,j)-p8w(i,kts+1,j) + airmas(1,1)=area(i,j) * delp / g +! +! we don't trust the u10,v10 values, is model layers are very thin near surface +! + if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) +! + dxy(1)=area(i,j) + ipr=0 + + airmas1(1,1,1) = airmas(1,1) + tc1(1,1,1,:) = tc + bems1(1,1,:) = bems + call source_ss( imx, jmx, lmx, number_ss_bins, dt, tc1,ilwi, dxy, w10m, airmas1, bems1,ipr) + tc = tc1(1,1,1,:) + chem(i,kts,j,p_seas_1)=(tc(1)+.75*tc(2))*converi + chem(i,kts,j,p_seas_2)=(tc(3)+.25*tc(2))*converi + seashelp(i,j)=tc(2)*converi + endif + enddo + enddo + + case default + + select case (seas_opt) + case (1) + ! -- original GOCART sea salt scheme + do j = jts, jte + do i = its, ite + + ! -- only use sea salt scheme over water + if (xland(i,j) < 0.5) then + + ! -- compute auxiliary variables + delp = p8w(i,kts,j)-p8w(i,kts+1,j) + if (dz8w(i,kts,j) < 12.) then + w10m = sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) + else + w10m = sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) + end if + + ilwi(1,1)=0 + tc = 0. + tskin(1,1)=tsk(i,j) + airmas(1,1)=area(i,j) * delp / g + dxy(1)=area(i,j) + ipr=0 + + airmas1(1,1,1) = airmas(1,1) + tc1(1,1,1,:) = tc + bems1(1,1,:) = bems + call source_ss( imx,jmx,lmx,number_ss_bins, dt, tc1, ilwi, dxy, w10m, airmas1, bems1,ipr) + tc = tc1(1,1,1,:) + bems = bems1(1,1,:) + + ! -- add sea salt emission increments to existing airborne concentrations + chem(i,kts,j,p_seas_1) = chem(i,kts,j,p_seas_1) + tc(1)*converi + chem(i,kts,j,p_seas_2) = chem(i,kts,j,p_seas_2) + tc(2)*converi + chem(i,kts,j,p_seas_3) = chem(i,kts,j,p_seas_3) + tc(3)*converi + chem(i,kts,j,p_seas_4) = chem(i,kts,j,p_seas_4) + tc(4)*converi + chem(i,kts,j,p_seas_5) = chem(i,kts,j,p_seas_5) + tc(5)*converi + !print*,'hli tc(2),chem(i,kts,j,p_seas_2)',tc(2),chem(i,kts,j,p_seas_2) + + ! for output diagnostics + emis_seas(i,1,j,p_eseas1) = bems(1) + emis_seas(i,1,j,p_eseas2) = bems(2) + emis_seas(i,1,j,p_eseas3) = bems(3) + emis_seas(i,1,j,p_eseas4) = bems(4) + emis_seas(i,1,j,p_eseas5) = bems(5) + + end if + + end do + end do + + case (2) + ! -- NGAC sea salt scheme + do j = jts, jte + do i = its, ite + + ! -- only use sea salt scheme over water + if (xland(i,j) < 0.5) then + + ! -- compute auxiliary variables + delp = p8w(i,kts,j)-p8w(i,kts+1,j) + if (dz8w(i,kts,j) < 12.) then + ws10m = sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) + else + ws10m = sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) + end if + + ! -- compute NGAC SST correction + tskin_c = tsk(i,j) - 273.15 + tskin_c = min(max(tskin_c, -0.1), 36.0) ! temperature range (0, 36) C + + fsstemis = -1.107211 & + - tskin_c*(0.010681+0.002276*tskin_c) & + + 60.288927/(40.0 - tskin_c) + fsstemis = min(max(fsstemis, 0.0), 7.0) + + do n = 1, number_ss_bins + memissions = 0. + nemissions = 0. + call SeasaltEmission( ra(n), rb(n), emission_scheme, & + ws10m, ustar(i,j), memissions, nemissions, rc ) +! if (chem_rc_test((rc /= 0), msg="Error in NGAC sea salt scheme", & +! file=__FILE__, line=__LINE__)) return + + bems(n) = emission_scale(n) * fsstemis * memissions + tc(n) = bems(n) * dt * g / delp + end do + + ! -- add sea salt emission increments to existing airborne concentrations + chem(i,kts,j,p_seas_1) = chem(i,kts,j,p_seas_1) + tc(1)*converi + chem(i,kts,j,p_seas_2) = chem(i,kts,j,p_seas_2) + tc(2)*converi + chem(i,kts,j,p_seas_3) = chem(i,kts,j,p_seas_3) + tc(3)*converi + chem(i,kts,j,p_seas_4) = chem(i,kts,j,p_seas_4) + tc(4)*converi + chem(i,kts,j,p_seas_5) = chem(i,kts,j,p_seas_5) + tc(5)*converi + + ! for output diagnostics kg/m2/s + emis_seas(i,1,j,p_eseas1) = bems(1) + emis_seas(i,1,j,p_eseas2) = bems(2) + emis_seas(i,1,j,p_eseas3) = bems(3) + emis_seas(i,1,j,p_eseas4) = bems(4) + emis_seas(i,1,j,p_eseas5) = bems(5) + end if + + end do + end do + + case default + ! -- no sea salt scheme + + end select + + end select + + end subroutine gocart_seasalt_driver + + SUBROUTINE source_ss(imx,jmx,lmx,nmx, dt1, tc, & + ilwi, dxy, w10m, airmas, & + bems,ipr) + +! **************************************************************************** +! * Evaluate the source of each seasalt particles size classes (kg/m3) +! * by soil emission. +! * Input: +! * SSALTDEN Sea salt density (kg/m3) +! * DXY Surface of each grid cell (m2) +! * NDT1 Time step (s) +! * W10m Velocity at the anemometer level (10meters) (m/s) +! * +! * Output: +! * DSRC Source of each sea salt bins (kg/timestep/cell) +! * +! * +! * Number flux density: Original formula by Monahan et al. (1986) adapted +! * by Sunling Gong (JGR 1997 (old) and GBC 2003 (new)). The new version is +! * to better represent emission of sub-micron sea salt particles. +! +! * dFn/dr = c1*u10**c2/(r**A) * (1+c3*r**c4)*10**(c5*exp(-B**2)) +! * where B = (b1 -log(r))/b2 +! * see c_old, c_new, b_old, b_new below for the constants. +! * number fluxes are at 80% RH. +! * +! * To calculate the flux: +! * 1) Calculate dFn based on Monahan et al. (1986) and Gong (2003) +! * 2) Assume that wet radius r at 80% RH = dry radius r_d *frh +! * 3) Convert particles flux to mass flux : +! * dFM/dr_d = 4/3*pi*rho_d*r_d^3 *(dr/dr_d) * dFn/dr +! * = 4/3*pi*rho_d*r_d^3 * frh * dFn/dr +! * where rho_p is particle density [kg/m3] +! * The factor 1.e-18 is to convert in micro-meter r_d^3 +! **************************************************************************** + + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: nmx,imx,jmx,lmx,ipr + INTEGER, INTENT(IN) :: ilwi(imx,jmx) + REAL(kind=kind_phys), INTENT(IN) :: dxy(jmx), w10m(imx,jmx) + REAL(kind=kind_phys), INTENT(IN) :: airmas(imx,jmx,lmx) + REAL(kind=kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) + REAL(kind=kind_phys), INTENT(OUT) :: bems(imx,jmx,nmx) + + REAL(kind=kind_phys) :: c0(5), b0(2) +! REAL(kind=kind_phys), PARAMETER :: c_old(5)=(/1.373, 3.41, 0.057, 1.05, 1.190/) +! REAL(kind=kind_phys), PARAMETER :: c_new(5)=(/1.373, 3.41, 0.057, 3.45, 1.607/) + ! Change suggested by MC + REAL(kind=kind_phys), PARAMETER :: c_old(5)=(/1.373, 3.2, 0.057, 1.05, 1.190/) + REAL(kind=kind_phys), PARAMETER :: c_new(5)=(/1.373, 3.2, 0.057, 3.45, 1.607/) + REAL(kind=kind_phys), PARAMETER :: b_old(2)=(/0.380, 0.650/) + REAL(kind=kind_phys), PARAMETER :: b_new(2)=(/0.433, 0.433/) + REAL(kind=kind_phys), PARAMETER :: dr=5.0D-2 ! um + REAL(kind=kind_phys), PARAMETER :: theta=30.0 + ! Swelling coefficient frh (d rwet / d rd) +!!! REAL(kind=kind_phys), PARAMETER :: frh = 1.65 + REAL(kind=kind_phys), PARAMETER :: frh = 2.d0 + LOGICAL, PARAMETER :: old=.TRUE., new=.FALSE. + REAL(kind=kind_phys) :: rho_d, r0, r1, r, r_w, a, b, dfn, r_d, dfm, src + INTEGER :: i, j, n, nr, ir + REAL(kind=kind_phys) :: dt1,fudge_fac + + + REAL(kind=kind_phys) :: tcmw(nmx), ar(nmx), tcvv(nmx) + REAL(kind=kind_phys) :: ar_wetdep(nmx), kc(nmx) + CHARACTER(LEN=20) :: tcname(nmx), tcunits(nmx) + LOGICAL :: aerosol(nmx) + + + REAL(kind=kind_phys) :: tc1(imx,jmx,lmx,nmx) + REAL(kind=kind_phys), TARGET :: tcms(imx,jmx,lmx,nmx) ! tracer mass (kg; kgS for sulfur case) + REAL(kind=kind_phys), TARGET :: tcgm(imx,jmx,lmx,nmx) ! g/m3 + + !----------------------------------------------------------------------- + ! sea salt specific + !----------------------------------------------------------------------- +! REAL(kind=kind_phys), DIMENSION(nmx) :: ra, rb +! REAL(kind=kind_phys) :: ch_ss(nmx,12) + + !----------------------------------------------------------------------- + ! emissions (input) + !----------------------------------------------------------------------- + REAL(kind=kind_phys) :: e_an(imx,jmx,2,nmx), e_bb(imx,jmx,nmx), & + e_ac(imx,jmx,lmx,nmx) + + !----------------------------------------------------------------------- + ! diagnostics (budget) + !----------------------------------------------------------------------- +! ! tendencies per time step and process +! REAL(kind=kind_phys), TARGET :: bems(imx,jmx,nmx), bdry(imx,jmx,nmx), bstl(imx,jmx,nmx) +! REAL(kind=kind_phys), TARGET :: bwet(imx,jmx,nmx), bcnv(imx,jmx,nmx)! + +! ! integrated tendencies per process +! REAL(kind=kind_phys), TARGET :: tems(imx,jmx,nmx), tstl(imx,jmx,nmx) +! REAL(kind=kind_phys), TARGET :: tdry(imx,jmx,nmx), twet(imx,jmx,nmx), tcnv(imx,jmx,nmx) + + ! global mass balance per time step + REAL(kind=kind_phys) :: tmas0(nmx), tmas1(nmx) + REAL(kind=kind_phys) :: dtems(nmx), dttrp(nmx), dtdif(nmx), dtcnv(nmx) + REAL(kind=kind_phys) :: dtwet(nmx), dtdry(nmx), dtstl(nmx) + REAL(kind=kind_phys) :: dtems2(nmx), dttrp2(nmx), dtdif2(nmx), dtcnv2(nmx) + REAL(kind=kind_phys) :: dtwet2(nmx), dtdry2(nmx), dtstl2(nmx) + + ! detailed integrated budgets for individual emissions + REAL(kind=kind_phys), TARGET :: ems_an(imx,jmx,nmx), ems_bb(imx,jmx,nmx), ems_tp(imx,jmx) + REAL(kind=kind_phys), TARGET :: ems_ac(imx,jmx,lmx,nmx) + REAL(kind=kind_phys), TARGET :: ems_co(imx,jmx,nmx) + + ! executable statements +! decrease seasalt emissions (Colarco et al. 2010) +! + !fudge_fac= 1. !.5 + !fudge_fac= .5 !lzhang + fudge_fac= .25 !lzhang +! + DO n = 1,nmx + bems(:,:,n) = 0.0 + rho_d = den_seas(n) + r0 = ra(n)*frh + r1 = rb(n)*frh + r = r0 + nr = INT((r1-r0)/dr+.001) + DO ir = 1,nr + r_w = r + dr*0.5 + r = r + dr + IF (new) THEN + a = 4.7*(1.0 + theta*r_w)**(-0.017*r_w**(-1.44)) + c0 = c_new + b0 = b_new + ELSE + a = 3.0 + c0 = c_old + b0 = b_old + END IF + ! + b = (b0(1) - LOG10(r_w))/b0(2) + dfn = (c0(1)/r_w**a)*(1.0 + c0(3)*r_w**c0(4))* & + 10**(c0(5)*EXP(-(b**2))) + + r_d = r_w/frh*1.0D-6 ! um -> m + dfm = 4.0/3.0*pi*r_d**3*rho_d*frh*dfn*dr*dt1 ! 3600 !dt1 + DO i = 1,imx + DO j = 1,jmx +! IF (water(i,j) > 0.0) THEN + IF (ilwi(i,j) == 0) THEN +! src = dfm*dxy(j)*water(i,j)*w10m(i,j)**c0(2) + src = dfm*dxy(j)*w10m(i,j)**c0(2) +! src = ch_ss(n,dt(1)%mn)*dfm*dxy(j)*w10m(i,j)**c0(2) + tc(i,j,1,n) = tc(i,j,1,n) + fudge_fac*src/airmas(i,j,1) + ELSE + src = 0.0 + END IF + bems(i,j,n) = bems(i,j,n) + src*fudge_fac/(dxy(j)*dt1) !kg/m2/s + END DO ! i + END DO ! j + END DO ! ir + END DO ! n + + END SUBROUTINE source_ss + +end module seas_mod diff --git a/smoke/seas_ngac_mod.F90 b/smoke/seas_ngac_mod.F90 new file mode 100755 index 000000000..73605ecc1 --- /dev/null +++ b/smoke/seas_ngac_mod.F90 @@ -0,0 +1,188 @@ +!------------------------------------------------------------------------- +! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! +! Adapted by NOAA/GSD/ESRL ! +!------------------------------------------------------------------------- +!BOP +! +! !MODULE: seas_ngac_mod.F90 --- Calculate the Seasalt Emissions +! +! !INTERFACE: +! + + module seas_ngac_mod + +! !USES: + +! use chem_comm_mod, only : chem_comm_isroot + use machine , only : kind_phys + use physcons, only : pi=>con_pi + + implicit none + +! !PUBLIC TYPES: +! + PRIVATE + +! +! !PUBLIC MEMBER FUNCTIONS: +! + + PUBLIC SeasaltEmission + + +! !CONSTANTS + real(kind=kind_phys), parameter :: r80fac = 1.65 ! ratio of radius(RH=0.8)/radius(RH=0.) [Gerber] + real(kind=kind_phys), parameter :: rhop = 2200. ! dry seasalt density [kg m-3] + +! +! !DESCRIPTION: +! +! This module implements the sea salt aerosol emission parameterizations. +! For all variants, emissions are some function of wind speed (and possibly +! other dynamical parameters) and the sea salt particle radius. Here, +! we assume the model passes in dry radius (or dry radius of size bin edges). +! Output is the mass emission flux (kg m-2 s-1) into that radius bin. +! +! !REVISION HISTORY: +! +! 30Mar2010 Colarco First crack! +! +!EOP +!------------------------------------------------------------------------- +CONTAINS +! +! !IROUTINE: SeasaltEmission - Master driver to compute the sea salt emissions +! +! !INTERFACE: +! + subroutine SeasaltEmission ( rLow, rUp, method, w10m, ustar, & + memissions, nemissions, rc ) + +! !DESCRIPTION: Calculates the seasalt mass emission flux every timestep. +! The particular method (algorithm) used for the calculation is based +! on the value of "method" passed on input. Mostly these algorithms are +! a function of wind speed and particle size (nominally at 80% RH). +! Routine is called once for each size bin, passing in the edge radii +! "rLow" and "rUp" (in dry radius, units of um). Returned in the emission +! mass flux [kg m-2 s-1]. A sub-bin assumption is made to break (possibly) +! large size bins into a smaller space. +! +! !USES: + + implicit NONE + +! !INPUT PARAMETERS: + + real(kind=kind_phys), intent(in) :: rLow, rUp ! Dry particle bin edge radii [um] + real(kind=kind_phys), intent(in) :: w10m ! 10-m wind speed [m s-1] + real(kind=kind_phys), intent(in) :: ustar ! friction velocity [m s-1] + integer, intent(in) :: method ! Algorithm to use + +! !OUTPUT PARAMETERS: + + real(kind=kind_phys), intent(inout) :: memissions ! Mass Emissions Flux [kg m-2 s-1] + real(kind=kind_phys), intent(inout) :: nemissions ! Number Emissions Flux [# m-2 s-1] + integer, intent(out) :: rc ! Error return code: + ! 0 - all is well + ! 1 - +! !Local Variables + integer :: ir + real(kind=kind_phys) :: w ! Intermediary wind speed [m s-1] + real(kind=kind_phys) :: r, dr ! sub-bin radius spacing (dry, um) + real(kind=kind_phys) :: rwet, drwet ! sub-bin radius spacing (rh=80%, um) + real(kind=kind_phys) :: aFac, bFac, scalefac, rpow, exppow, wpow + + integer, parameter :: nr = 10 ! Number of (linear) sub-size bins + + character(len=*), parameter :: myname = 'SeasaltEmission' + +! Define the sub-bins (still in dry radius) + dr = (rUp - rLow)/nr + r = rLow + 0.5*dr + +! Loop over size bins + nemissions = 0. + memissions = 0. + + do ir = 1, nr + + rwet = r80fac * r + drwet = r80fac * dr + + select case(method) + + case(1) ! Gong 2003 + aFac = 4.7*(1.+30.*rwet)**(-0.017*rwet**(-1.44)) + bFac = (0.433-log10(rwet))/0.433 + scalefac = 1. + rpow = 3.45 + exppow = 1.607 + wpow = 3.41 + w = w10m + + case(2) ! Gong 1997 + aFac = 3. + bFac = (0.380-log10(rwet))/0.650 + scalefac = 1. + rpow = 1.05 + exppow = 1.19 + wpow = 3.41 + w = w10m + + case(3) ! GEOS5 2012 + aFac = 4.7*(1.+30.*rwet)**(-0.017*rwet**(-1.44)) + bFac = (0.433-log10(rwet))/0.433 + scalefac = 33.0e3 + rpow = 3.45 + exppow = 1.607 + wpow = 3.41 - 1. + w = ustar + + case default +! if(chem_comm_isroot()) print *, 'SeasaltEmission missing algorithm method' + rc = 1 + return + + end select + + +! Number emissions flux (# m-2 s-1) + nemissions = nemissions + SeasaltEmissionGong( rwet, drwet, w, scalefac, aFac, bFac, rpow, exppow, wpow ) +! Mass emissions flux (kg m-2 s-1) + scalefac = scalefac * 4./3.*pi*rhop*r**3.*1.e-18 + memissions = memissions + SeasaltEmissionGong( rwet, drwet, w, scalefac, aFac, bFac, rpow, exppow, wpow ) + + r = r + dr + + end do + + rc = 0 + + end subroutine SeasaltEmission + + +! Function to compute sea salt emissions following the Gong style +! parameterization. Functional form is from Gong 2003: +! dN/dr = scalefac * 1.373 * (w^wpow) * (r^-aFac) * (1+0.057*r^rpow) * 10^(exppow*exp(-bFac^2)) +! where r is the particle radius at 80% RH, dr is the size bin width at 80% RH, and w is the wind speed + + function SeasaltEmissionGong ( r, dr, w, scalefac, aFac, bFac, rpow, exppow, wpow ) + + real(kind=kind_phys), intent(in) :: r, dr ! Wet particle radius, bin width [um] + real(kind=kind_phys), intent(in) :: w ! Grid box mean wind speed [m s-1] (10-m or ustar wind) + real(kind=kind_phys), intent(in) :: scalefac, aFac, bFac, rpow, exppow, wpow + real(kind=kind_phys) :: SeasaltEmissionGong + +! Initialize + SeasaltEmissionGong = 0. + +! Particle size distribution function + SeasaltEmissionGong = scalefac * 1.373*r**(-aFac)*(1.+0.057*r**rpow) & + *10**(exppow*exp(-bFac**2.))*dr +! Apply wind speed function + SeasaltEmissionGong = w**wpow * SeasaltEmissionGong + + end function SeasaltEmissionGong + + + end module seas_ngac_mod From 0aab5550cfb756a763c798a6f7d3decda23d70c6 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Fri, 8 Apr 2022 18:41:55 +0000 Subject: [PATCH 159/217] Reorder declarations. --- physics/mp_thompson.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index d8dbc9300..aa9404928 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -689,9 +689,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & 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_prt_list=spp_prt_list, & - spp_stddev_cutoff=spp_stddev_cutoff, n_var_spp=n_var_spp, & - spp_var_list=spp_var_list, & + rand_pert=spp_wts_mp, spp_var_list=spp_var_list, & + spp_prt_list=spp_prt_list, n_var_spp=n_var_spp, & + spp_stddev_cutoff=spp_stddev_cutoff, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & From ec7a0429053325a6b0a6435085da0d90b41e32c4 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Fri, 8 Apr 2022 20:04:35 +0000 Subject: [PATCH 160/217] "update physics for Smoke" --- physics/GFS_DCNV_generic.F90 | 11 +++++-- physics/GFS_DCNV_generic.meta | 15 +++++++++ physics/GFS_SCNV_generic.F90 | 14 ++++++-- physics/GFS_SCNV_generic.meta | 15 +++++++++ physics/GFS_rrtmg_pre.F90 | 12 +++++++ physics/GFS_rrtmg_pre.meta | 23 +++++++++++++ physics/GFS_suite_interstitial.F90 | 16 +++++++-- physics/GFS_suite_interstitial.meta | 15 +++++++++ physics/module_MYNNPBL_wrapper.F90 | 51 +++++++++++++++-------------- physics/module_MYNNPBL_wrapper.meta | 30 +++++++++++++++++ physics/module_bl_mynn.F90 | 23 ++++++++++++- physics/module_mp_thompson.F90 | 5 ++- physics/mp_thompson.F90 | 4 ++- physics/mp_thompson.meta | 7 ++++ 14 files changed, 208 insertions(+), 33 deletions(-) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index e7dec5ca1..4c5e7f717 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -20,7 +20,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc save_u, save_v, save_t, save_q, clw, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & ntgnc, cscnv, satmedmf, trans_trac, ras, ntrac, & - dtidx, index_of_process_dcnv, errmsg, errflg) + dtidx, index_of_process_dcnv,rrfs_smoke,dqdti, & + errmsg, errflg) use machine, only: kind_phys @@ -28,7 +29,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc - logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm + logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm, rrfs_smoke real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 @@ -37,6 +38,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc real(kind=kind_phys), dimension(:,:), intent(inout) :: save_v real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q + ! dqdti only allocated if rrfs_smoke is .true. + real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg logical, intent(in) :: cscnv, satmedmf, trans_trac, ras @@ -88,6 +91,10 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc save_q(:,:,ntqv) = gq0(:,:,ntqv) endif + if (rrfs_smoke) then + dqdti = zero + endif + end subroutine GFS_DCNV_generic_pre_run end module GFS_DCNV_generic_pre diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index 47fb65d9a..1d7d87c17 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -247,6 +247,21 @@ dimensions = () type = integer intent = in +[rrfs_smoke] + standard_name = flag_for_rrfs_smoke_coupling + long_name = flag controlling rrfs_smoke collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[dqdti] + standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection + long_name = instantaneous moisture tendency due to convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_SCNV_generic.F90 b/physics/GFS_SCNV_generic.F90 index 58447f6bf..45fc3dd2d 100644 --- a/physics/GFS_SCNV_generic.F90 +++ b/physics/GFS_SCNV_generic.F90 @@ -99,7 +99,7 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & index_of_process_scnv, ntqv, flag_for_scnv_generic_tend, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & imfshalcnv, imfshalcnv_sas, imfshalcnv_samf, ntrac, & - cscnv, satmedmf, trans_trac, ras, errmsg, errflg) + cscnv, satmedmf, trans_trac, ras, rrfs_smoke, dqdti, errmsg, errflg) use machine, only: kind_phys @@ -107,13 +107,14 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & integer, intent(in) :: im, levs, nn, ntqv, nsamftrac integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac - logical, intent(in) :: lssav, ldiag3d, qdiag3d, flag_for_scnv_generic_tend + logical, intent(in) :: lssav, ldiag3d, qdiag3d, flag_for_scnv_generic_tend, rrfs_smoke real(kind=kind_phys), intent(in) :: frain real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 real(kind=kind_phys), dimension(:,:), intent(in) :: save_u, save_v, save_t real(kind=kind_phys), dimension(:,:,:), intent(in) :: save_q, gq0 ! dtend only allocated if ldiag3d == .true. + real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti real(kind=kind_phys), intent(inout) :: dtend(:,:,:) integer, intent(in) :: dtidx(:,:) integer, intent(in) :: index_of_temperature, index_of_x_wind, index_of_y_wind, index_of_process_scnv @@ -209,6 +210,15 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & endif endif + if (rrfs_smoke) then + do k=1,levs + do i=1,im + tem = (gq0_water_vapor(i,k)-save_qv(i,k)) * frain + dqdti(i,k) = dqdti(i,k) + tem + enddo + enddo + endif + end subroutine GFS_SCNV_generic_post_run end module GFS_SCNV_generic_post diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index 5cbda127c..d1b4b452b 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -663,6 +663,21 @@ dimensions = () type = integer intent = in +[rrfs_smoke] + standard_name = flag_for_rrfs_smoke_coupling + long_name = flag controlling rrfs_smoke collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[dqdti] + standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection + long_name = instantaneous moisture tendency due to convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index db818c3b8..f29dbfd5e 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -36,6 +36,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & + aero_dir_fdb, smoke_ext, dust_ext, & spp_wts_rad, spp_rad, errmsg, errflg) use machine, only: kind_phys @@ -103,6 +104,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & logical, intent(in) :: lsswr, lslwr, ltaerosol, lgfdlmprad, & uni_cld, effr_in, do_mynnedmf, & lmfshal, lmfdeep2, pert_clds + logical, intent(in) :: aero_dir_fdb + real(kind=kind_phys), dimension(:,:), intent(in) :: smoke_ext, dust_ext integer, intent(in) :: spp_rad real(kind_phys), intent(in) :: spp_wts_rad(:,:) @@ -601,6 +604,15 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo + if(aero_dir_fdb) then ! add smoke/dust extinctions + do k = 1, LMK + do i = 1, IM + ! 550nm (~18000/cm) + faersw1(i,k,10) = faersw1(i,k,10) + MAX(4.,smoke_ext(i,k) + dust_ext(i,k)) + enddo + enddo + endif + do j = 1,NBDLW do k = 1, LMK do i = 1, IM diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 1eac8a571..0e24b504a 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1082,6 +1082,29 @@ type = real kind = kind_phys intent = out +[aero_dir_fdb] + standard_name = rrfs_smoke_dust_rad_fdb_opt + long_name = flag for rrfs smoke dust rad feedback + units = flag + dimensions = () + type = logical + intent = in +[smoke_ext] + standard_name = smoke_ext + long_name = smoke optical extinction + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dust_ext] + standard_name = dust_ext + long_name = dust optical extinction + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [spp_wts_rad] standard_name = spp_weights_for_radiation_scheme long_name = spp weights for radiation scheme diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 6963e94c3..591e27d88 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -701,7 +701,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & - qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) + qdiag3d, save_lnc, save_inc, ntk, ntke, rrfs_smoke, dqdti, errmsg, errflg) use machine, only: kind_phys use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber @@ -714,7 +714,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf - logical, intent(in) :: ltaerosol, convert_dry_rho + logical, intent(in) :: ltaerosol, convert_dry_rho, rrfs_smoke real(kind=kind_phys), intent(in ) :: con_pi, dtf real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc @@ -734,6 +734,9 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp real(kind=kind_phys), dimension(:,:), intent(in) :: spechum + ! dqdti may not be allocated + real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti + character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -919,6 +922,15 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo endif ! end if_ntcw +! dqdt_v : instaneous moisture tendency (kg/kg/sec) + if (rrfs_smoke) then + do k=1,levs + do i=1,im + dqdti(i,k) = dqdti(i,k) * (1.0 / dtf) + enddo + enddo + endif + end subroutine GFS_suite_interstitial_4_run end module GFS_suite_interstitial_4 diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 43b3d5efa..c994f1363 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1808,6 +1808,21 @@ dimensions = () type = integer intent = in +[rrfs_smoke] + standard_name = flag_for_rrfs_smoke_coupling + long_name = flag controlling rrfs_smoke collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[dqdti] + standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection + long_name = instantaneous moisture tendency due to convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index d9e53f9d3..c1d93536f 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -159,6 +159,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & + & chem3d, frp, mix_chem, fire_turb, & & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: @@ -182,7 +183,7 @@ SUBROUTINE mynnedmf_wrapper_run( & !logical, intent(in) :: mix_chem, fire_turb !integer, intent(in) :: nchem, ndvel, kdvel !for testing only: - logical, parameter :: mix_chem=.false., fire_turb=.false. + !logical, parameter :: mix_chem=.false., fire_turb=.false. integer, parameter :: nchem=2, ndvel=2, kdvel=1 ! NAMELIST OPTIONS (INPUT): @@ -287,15 +288,17 @@ SUBROUTINE mynnedmf_wrapper_run( & !smoke/chem arrays ! real(kind=kind_phys), dimension(:,:), intent(inout), optional :: & ! & qgrs_smoke_conc, qgrs_dust_conc - ! real(kind=kind_phys), allocatable, dimension(:,:,:) :: chem3d - ! real(kind=kind_phys), dimension(:,:), intent(in), optional :: vdep - ! real(kind=kind_phys), dimension(:), intent(in), optional :: frp, emis_ant_no + real(kind_phys), dimension(:), intent(inout) :: frp + logical, intent(in) :: mix_chem, fire_turb + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind=kind_phys), dimension(im) :: emis_ant_no + real(kind=kind_phys), dimension(im,ndvel) :: vdep !for testing only - real(kind=kind_phys), dimension(im,levs) :: & - & qgrs_smoke_conc, qgrs_dust_conc - real(kind=kind_phys), allocatable, dimension(:,:,:) :: chem3d - real(kind=kind_phys), dimension(im,ndvel) :: vdep !not passed in yet??? - real(kind=kind_phys), dimension(im) :: frp, emis_ant_no +! real(kind=kind_phys), dimension(im,levs) :: & +! & qgrs_smoke_conc, qgrs_dust_conc +! real(kind=kind_phys), allocatable, dimension(:,:,:) :: chem3d +! real(kind=kind_phys), dimension(im,ndvel) :: vdep !not passed in yet??? +! real(kind=kind_phys), dimension(im) :: frp, emis_ant_no !MYNN-2D real(kind=kind_phys), dimension(:), intent(in) :: & @@ -361,20 +364,20 @@ SUBROUTINE mynnedmf_wrapper_run( & endif !initialize arrays for test - qgrs_smoke_conc = 1.0 - qgrs_dust_conc = 1.0 - FRP = 0. + !qgrs_smoke_conc = 1.0 + !qgrs_dust_conc = 1.0 + !FRP = 0. EMIS_ANT_NO = 0. vdep = 0. ! hli for chem dry deposition, 0 temporarily - if (mix_chem) then - allocate ( chem3d(im,levs,nchem) ) - do k=1,levs - do i=1,im - chem3d(i,k,1)=qgrs_smoke_conc(i,k) - chem3d(i,k,2)=qgrs_dust_conc (i,k) - enddo - enddo - endif + !if (mix_chem) then + ! allocate ( chem3d(im,levs,nchem) ) + ! do k=1,levs + ! do i=1,im + ! chem3d(i,k,1)=qgrs_smoke_conc(i,k) + ! chem3d(i,k,2)=qgrs_dust_conc (i,k) + ! enddo + ! enddo + !endif ! Check incoming moist species to ensure non-negative values ! First, create height (dz) and pressure differences (delp) @@ -966,9 +969,9 @@ SUBROUTINE mynnedmf_wrapper_run( & deallocate(save_qke_adv) endif - if(allocated(chem3d))then - deallocate(chem3d) - endif +! if(allocated(chem3d))then +! deallocate(chem3d) +! endif CONTAINS diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 658c80100..d9c2ebf50 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1313,6 +1313,36 @@ dimensions = () type = integer intent = in +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + type = real + kind = kind_phys + intent = inout +[frp] + standard_name = frp_hourly + long_name = hourly frp + units = mw + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[mix_chem] + standard_name = rrfs_smoke_mynn_tracer_mixing + long_name = flag for rrfs smoke mynn tracer mixing + units = flag + dimensions = () + type = logical + intent = in +[fire_turb] + standard_name = rrfs_smoke_mynn_enh_vermix + long_name = flag for rrfs smoke mynn enh vermix + units = flag + dimensions = () + type = logical + intent = in [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 292d5aa18..38dcc95df 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -5348,7 +5348,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & REAL, DIMENSION(kts:kte) :: rhoinv REAL, DIMENSION(kts:kte+1) :: rhoz,khdz REAL, PARAMETER :: no_threshold = 0.1 - REAL, PARAMETER :: frp_threshold = 1.0 ! JLS 12/21/21 + REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing REAL, PARAMETER :: pblh_threshold = 250.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5362,6 +5362,27 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & rhoz(kts) =rho(kts) rhoinv(kts)=1./rho(kts) khdz(kts) =rhoz(kts)*dfh(kts) + + khdz_old = khdz(kts) + khdz_back = pblh * 0.15 / dz(kts) + !Enhance diffusion over fires + IF ( fire_turb ) THEN + IF ( pblh < pblh_threshold ) THEN + IF ( emis_ant_no > no_threshold ) THEN +! khdz(kts) = MAX(khdz(kts),khdz_back) + khdz(kts) = MAX(1.1*khdz(kts), sqrt((emis_ant_no / no_threshold))/dz(kts)*rhoz(kts)) ! JLS 12/21/21 + ENDIF + IF ( frp > frp_threshold ) THEN + !kmaxfire = ceiling(log(curr_frp)) ! JLS 12/21/21 - need to bring in curr_frp + kmaxfire = ceiling(log(frp)) + IF (k .le. kmaxfire) THEN ! JLS +! khdz(kts) = MAX(khdz(kts),khdz_back) + khdz(kts) = MAX(1.1*khdz(kts),((log(frp))**2.- 2.*log(frp)) / dz(kts)*rhoz(kts)) ! JLS 12/21/21 + ENDIF ! JLS + ENDIF + ENDIF + ENDIF + DO k=kts+1,kte rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) rhoz(k) = MAX(rhoz(k),1E-4) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index c23b6d1d8..1cd5db703 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -968,7 +968,7 @@ END SUBROUTINE thompson_init !> @{ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nwfa, nifa, nwfa2d, nifa2d, & - tt, th, pii, & + aero_ind_fdb, tt, th, pii, & p, w, dz, dt_in, dt_inner, & sedi_semi, decfl, & RAINNC, RAINNCV, & @@ -1023,6 +1023,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & nc, nwfa, nifa REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d, nifa2d + LOGICAL, OPTIONAL, INTENT(IN):: aero_ind_fdb REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & re_cloud, re_ice, re_snow INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch @@ -1446,8 +1447,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & !.. Changed 13 May 2013 to fake emissions in which nwfa2d is aerosol !.. number tendency (number per kg per second). if (is_aerosol_aware) then + if ( .not. aero_ind_fdb) then nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt + endif do k = kts, kte nc(i,k,j) = nc1d(k) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 7c76ea933..dd49d3c8c 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -300,7 +300,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & con_eps, convert_dry_rho, & spechum, qc, qr, qi, qs, qg, ni, nr, & is_aerosol_aware, nc, nwfa, nifa, & - nwfa2d, nifa2d, & + nwfa2d, nifa2d, aero_ind_fdb, & tgrs, prsl, phii, omega, & sedi_semi, decfl, dtp, dt_inner, & first_time_step, istep, nsteps, & @@ -339,6 +339,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), optional, intent(inout) :: nifa(:,:) real(kind_phys), optional, intent(in ) :: nwfa2d(:) real(kind_phys), optional, intent(in ) :: nifa2d(:) + logical, optional, intent(in ) :: aero_ind_fdb ! State variables and timestep information real(kind_phys), intent(inout) :: tgrs(:,:) real(kind_phys), intent(in ) :: prsl(:,:) @@ -634,6 +635,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & if (is_aerosol_aware) then call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & + aero_ind_fdb=aero_ind_fdb, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, dt_inner=dt_inner, & sedi_semi=sedi_semi, decfl=decfl, & rainnc=rain_mp, rainncv=delta_rain_mp, & diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index a3bc20615..49bb15935 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -435,6 +435,13 @@ type = real kind = kind_phys intent = in +[aero_ind_fdb] + standard_name = rrfs_smoke_aero_ind_fdb_opt + long_name = flag for rrfs wfa ifa emission + units = flag + dimensions = () + type = logical + intent = in [tgrs] standard_name = air_temperature_of_new_state long_name = model layer mean temperature From c2754623fea3b851a5d5c77c9ebe93c117852828 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sun, 10 Apr 2022 21:04:14 -0600 Subject: [PATCH 161/217] Also change GFS_interstitial_type import in GFS_debug.F90 --- physics/GFS_debug.F90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index f01f25cbc..5b3d8f9c1 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -316,8 +316,8 @@ module GFS_diagtoscreen !! subroutine GFS_diagtoscreen_init (Model, Data, Interstitial, errmsg, errflg) - use GFS_typedefs, only: GFS_control_type, GFS_data_type, & - GFS_interstitial_type + use GFS_typedefs, only: GFS_control_type, GFS_data_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -349,8 +349,8 @@ end subroutine GFS_diagtoscreen_init !! subroutine GFS_diagtoscreen_timestep_init (Model, Data, Interstitial, errmsg, errflg) - use GFS_typedefs, only: GFS_control_type, GFS_data_type, & - GFS_interstitial_type + use GFS_typedefs, only: GFS_control_type, GFS_data_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -397,8 +397,8 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, GFS_stateout_type, GFS_sfcprop_type, & GFS_coupling_type, GFS_grid_type, & GFS_tbd_type, GFS_cldprop_type, & - GFS_radtend_type, GFS_diag_type, & - GFS_interstitial_type + GFS_radtend_type, GFS_diag_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -967,8 +967,8 @@ module GFS_interstitialtoscreen !! subroutine GFS_interstitialtoscreen_init (Model, Data, Interstitial, errmsg, errflg) - use GFS_typedefs, only: GFS_control_type, GFS_data_type, & - GFS_interstitial_type + use GFS_typedefs, only: GFS_control_type, GFS_data_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -1001,8 +1001,8 @@ end subroutine GFS_interstitialtoscreen_init !! subroutine GFS_interstitialtoscreen_timestep_init (Model, Data, Interstitial, errmsg, errflg) - use GFS_typedefs, only: GFS_control_type, GFS_data_type, & - GFS_interstitial_type + use GFS_typedefs, only: GFS_control_type, GFS_data_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -1051,8 +1051,8 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup GFS_stateout_type, GFS_sfcprop_type, & GFS_coupling_type, GFS_grid_type, & GFS_tbd_type, GFS_cldprop_type, & - GFS_radtend_type, GFS_diag_type, & - GFS_interstitial_type + GFS_radtend_type, GFS_diag_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none From 67068c8bb60bfc584cda9f09b3f290ab463ff52a Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 8 Apr 2022 13:43:13 -0400 Subject: [PATCH 162/217] enforce one file per module for CCPP scheme entry points --- ..._generic.F90 => GFS_DCNV_generic_post.F90} | 102 +- ...eneric.meta => GFS_DCNV_generic_post.meta} | 293 --- physics/GFS_DCNV_generic_pre.F90 | 90 + physics/GFS_DCNV_generic_pre.meta | 292 +++ physics/GFS_GWD_generic_post.F90 | 67 + physics/GFS_GWD_generic_post.meta | 153 ++ ...WD_generic.F90 => GFS_GWD_generic_pre.F90} | 94 +- ..._generic.meta => GFS_GWD_generic_pre.meta} | 156 +- ...MP_generic.F90 => GFS_MP_generic_post.F90} | 75 +- ..._generic.meta => GFS_MP_generic_post.meta} | 120 - physics/GFS_MP_generic_pre.F90 | 62 + physics/GFS_MP_generic_pre.meta | 119 + physics/GFS_PBL_generic_common.F90 | 73 + ...L_generic.F90 => GFS_PBL_generic_post.F90} | 387 +--- ...generic.meta => GFS_PBL_generic_post.meta} | 435 +--- physics/GFS_PBL_generic_pre.F90 | 300 +++ physics/GFS_PBL_generic_pre.meta | 432 ++++ ..._generic.F90 => GFS_SCNV_generic_post.F90} | 87 +- ...eneric.meta => GFS_SCNV_generic_post.meta} | 258 --- physics/GFS_SCNV_generic_pre.F90 | 73 + physics/GFS_SCNV_generic_pre.meta | 257 +++ physics/GFS_suite_interstitial.F90 | 1043 --------- physics/GFS_suite_interstitial.meta | 1966 ----------------- physics/GFS_suite_interstitial_1.F90 | 66 + physics/GFS_suite_interstitial_1.meta | 165 ++ physics/GFS_suite_interstitial_2.F90 | 236 ++ physics/GFS_suite_interstitial_2.meta | 488 ++++ physics/GFS_suite_interstitial_3.F90 | 195 ++ physics/GFS_suite_interstitial_3.meta | 458 ++++ physics/GFS_suite_interstitial_4.F90 | 293 +++ physics/GFS_suite_interstitial_4.meta | 391 ++++ physics/GFS_suite_interstitial_5.F90 | 43 + physics/GFS_suite_interstitial_5.meta | 83 + physics/GFS_suite_interstitial_phys_reset.F90 | 31 + .../GFS_suite_interstitial_phys_reset.meta | 39 + physics/GFS_suite_interstitial_rad_reset.F90 | 31 + physics/GFS_suite_interstitial_rad_reset.meta | 38 + physics/GFS_suite_stateout_reset.F90 | 43 + physics/GFS_suite_stateout_reset.meta | 110 + physics/GFS_suite_stateout_update.F90 | 63 + physics/GFS_suite_stateout_update.meta | 186 ++ physics/GFS_surface_composites_inter.F90 | 71 + physics/GFS_surface_composites_inter.meta | 133 ++ ...es.F90 => GFS_surface_composites_post.F90} | 384 +--- ....meta => GFS_surface_composites_post.meta} | 624 +----- physics/GFS_surface_composites_pre.F90 | 293 +++ physics/GFS_surface_composites_pre.meta | 487 ++++ physics/GFS_surface_loop_control_part1.F90 | 51 + physics/GFS_surface_loop_control_part1.meta | 53 + ...F90 => GFS_surface_loop_control_part2.F90} | 65 +- ...ta => GFS_surface_loop_control_part2.meta} | 54 - physics/cs_conv.F90 | 118 - physics/cs_conv.meta | 213 -- physics/cs_conv_post.F90 | 46 + physics/cs_conv_post.meta | 62 + physics/cs_conv_pre.F90 | 64 + physics/cs_conv_pre.meta | 149 ++ physics/get_phi_fv3.F90 | 56 + physics/get_phi_fv3.meta | 87 + physics/get_prs_fv3.F90 | 77 +- physics/get_prs_fv3.meta | 93 +- physics/gwdc.f | 172 +- physics/gwdc.meta | 330 +-- physics/gwdc_post.f | 82 + physics/gwdc_post.meta | 186 ++ physics/gwdc_pre.f | 68 + physics/gwdc_pre.meta | 140 ++ physics/m_micro_interstitial.F90 | 277 --- physics/m_micro_post.F90 | 127 ++ physics/m_micro_post.meta | 190 ++ physics/m_micro_pre.F90 | 135 ++ ...cro_interstitial.meta => m_micro_pre.meta} | 193 +- physics/sfc_nst.f | 221 +- physics/sfc_nst.meta | 329 +-- physics/sfc_nst_post.f | 92 + physics/sfc_nst_post.meta | 192 ++ physics/sfc_nst_pre.f | 99 + physics/sfc_nst_pre.meta | 133 ++ 78 files changed, 7898 insertions(+), 8141 deletions(-) rename physics/{GFS_DCNV_generic.F90 => GFS_DCNV_generic_post.F90} (59%) rename physics/{GFS_DCNV_generic.meta => GFS_DCNV_generic_post.meta} (62%) create mode 100644 physics/GFS_DCNV_generic_pre.F90 create mode 100644 physics/GFS_DCNV_generic_pre.meta create mode 100644 physics/GFS_GWD_generic_post.F90 create mode 100644 physics/GFS_GWD_generic_post.meta rename physics/{GFS_GWD_generic.F90 => GFS_GWD_generic_pre.F90} (60%) rename physics/{GFS_GWD_generic.meta => GFS_GWD_generic_pre.meta} (60%) rename physics/{GFS_MP_generic.F90 => GFS_MP_generic_post.F90} (88%) rename physics/{GFS_MP_generic.meta => GFS_MP_generic_post.meta} (86%) create mode 100644 physics/GFS_MP_generic_pre.F90 create mode 100644 physics/GFS_MP_generic_pre.meta create mode 100644 physics/GFS_PBL_generic_common.F90 rename physics/{GFS_PBL_generic.F90 => GFS_PBL_generic_post.F90} (56%) rename physics/{GFS_PBL_generic.meta => GFS_PBL_generic_post.meta} (69%) create mode 100644 physics/GFS_PBL_generic_pre.F90 create mode 100644 physics/GFS_PBL_generic_pre.meta rename physics/{GFS_SCNV_generic.F90 => GFS_SCNV_generic_post.F90} (63%) rename physics/{GFS_SCNV_generic.meta => GFS_SCNV_generic_post.meta} (62%) create mode 100644 physics/GFS_SCNV_generic_pre.F90 create mode 100644 physics/GFS_SCNV_generic_pre.meta delete mode 100644 physics/GFS_suite_interstitial.F90 delete mode 100644 physics/GFS_suite_interstitial.meta create mode 100644 physics/GFS_suite_interstitial_1.F90 create mode 100644 physics/GFS_suite_interstitial_1.meta create mode 100644 physics/GFS_suite_interstitial_2.F90 create mode 100644 physics/GFS_suite_interstitial_2.meta create mode 100644 physics/GFS_suite_interstitial_3.F90 create mode 100644 physics/GFS_suite_interstitial_3.meta create mode 100644 physics/GFS_suite_interstitial_4.F90 create mode 100644 physics/GFS_suite_interstitial_4.meta create mode 100644 physics/GFS_suite_interstitial_5.F90 create mode 100644 physics/GFS_suite_interstitial_5.meta create mode 100644 physics/GFS_suite_interstitial_phys_reset.F90 create mode 100644 physics/GFS_suite_interstitial_phys_reset.meta create mode 100644 physics/GFS_suite_interstitial_rad_reset.F90 create mode 100644 physics/GFS_suite_interstitial_rad_reset.meta create mode 100644 physics/GFS_suite_stateout_reset.F90 create mode 100644 physics/GFS_suite_stateout_reset.meta create mode 100644 physics/GFS_suite_stateout_update.F90 create mode 100644 physics/GFS_suite_stateout_update.meta create mode 100644 physics/GFS_surface_composites_inter.F90 create mode 100644 physics/GFS_surface_composites_inter.meta rename physics/{GFS_surface_composites.F90 => GFS_surface_composites_post.F90} (52%) rename physics/{GFS_surface_composites.meta => GFS_surface_composites_post.meta} (63%) create mode 100644 physics/GFS_surface_composites_pre.F90 create mode 100644 physics/GFS_surface_composites_pre.meta create mode 100644 physics/GFS_surface_loop_control_part1.F90 create mode 100644 physics/GFS_surface_loop_control_part1.meta rename physics/{GFS_surface_loop_control.F90 => GFS_surface_loop_control_part2.F90} (51%) rename physics/{GFS_surface_loop_control.meta => GFS_surface_loop_control_part2.meta} (67%) create mode 100644 physics/cs_conv_post.F90 create mode 100644 physics/cs_conv_post.meta create mode 100644 physics/cs_conv_pre.F90 create mode 100644 physics/cs_conv_pre.meta create mode 100644 physics/get_phi_fv3.F90 create mode 100644 physics/get_phi_fv3.meta create mode 100644 physics/gwdc_post.f create mode 100644 physics/gwdc_post.meta create mode 100644 physics/gwdc_pre.f create mode 100644 physics/gwdc_pre.meta delete mode 100644 physics/m_micro_interstitial.F90 create mode 100644 physics/m_micro_post.F90 create mode 100644 physics/m_micro_post.meta create mode 100644 physics/m_micro_pre.F90 rename physics/{m_micro_interstitial.meta => m_micro_pre.meta} (58%) create mode 100644 physics/sfc_nst_post.f create mode 100644 physics/sfc_nst_post.meta create mode 100644 physics/sfc_nst_pre.f create mode 100644 physics/sfc_nst_pre.meta diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic_post.F90 similarity index 59% rename from physics/GFS_DCNV_generic.F90 rename to physics/GFS_DCNV_generic_post.F90 index a9e0ba7e0..96901a568 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic_post.F90 @@ -1,110 +1,10 @@ -!> \file GFS_DCNV_generic.F90 +!> \file GFS_DCNV_generic_post.F90 !! Contains code related to deep convective schemes to be used within the GFS physics suite. - module GFS_DCNV_generic_pre - - contains - - subroutine GFS_DCNV_generic_pre_init () - end subroutine GFS_DCNV_generic_pre_init - - subroutine GFS_DCNV_generic_pre_finalize() - end subroutine GFS_DCNV_generic_pre_finalize - -!> \brief Interstitial scheme called prior to any deep convective scheme to save state variables for calculating tendencies after the deep convective scheme is executed -!! \section arg_table_GFS_DCNV_generic_pre_run Argument Table -!! \htmlinclude GFS_DCNV_generic_pre_run.html -!! - subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplchm, & - gu0, gv0, gt0, gq0, nsamftrac, ntqv, & - save_u, save_v, save_t, save_q, clw, & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv, & - cscnv, satmedmf, trans_trac, ras, ntrac, & - dtidx, index_of_process_dcnv, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv - logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm - real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 - real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 - real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: gq0 - real(kind=kind_phys), dimension(:,:), intent(inout) :: save_u - real(kind=kind_phys), dimension(:,:), intent(inout) :: save_v - real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - logical, intent(in) :: cscnv, satmedmf, trans_trac, ras - real(kind=kind_phys), parameter :: zero = 0.0d0 - real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw - - integer :: i, k, n, tracers - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (ldiag3d) then - do k=1,levs - do i=1,im - save_t(i,k) = gt0(i,k) - save_u(i,k) = gu0(i,k) - save_v(i,k) = gv0(i,k) - enddo - enddo - elseif (do_cnvgwd) then - do k=1,levs - do i=1,im - save_t(i,k) = gt0(i,k) - enddo - enddo - endif - - if ((ldiag3d.and.qdiag3d) .or. cplchm) then - if (cscnv .or. satmedmf .or. trans_trac .or. ras) then - tracers = 2 - do n=2,ntrac - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & - n /= nthl .and. n /= nthnc .and. n /= nthv .and. & - n /= ntgv ) then - tracers = tracers + 1 - if(dtidx(100+n,index_of_process_dcnv)>0) then - save_q(:,:,n) = clw(:,:,tracers) - endif - endif - enddo - else - do n=2,ntrac - if(dtidx(100+n,index_of_process_dcnv)>0) then - save_q(:,:,n) = gq0(:,:,n) - endif - enddo - endif ! end if_ras or cfscnv or samf - save_q(:,:,ntqv) = gq0(:,:,ntqv) - endif - - end subroutine GFS_DCNV_generic_pre_run - - end module GFS_DCNV_generic_pre - module GFS_DCNV_generic_post contains - subroutine GFS_DCNV_generic_post_init () - end subroutine GFS_DCNV_generic_post_init - - subroutine GFS_DCNV_generic_post_finalize () - end subroutine GFS_DCNV_generic_post_finalize - !> \section arg_table_GFS_DCNV_generic_post_run Argument Table !! \htmlinclude GFS_DCNV_generic_post_run.html !! diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic_post.meta similarity index 62% rename from physics/GFS_DCNV_generic.meta rename to physics/GFS_DCNV_generic_post.meta index e15acaf1c..9fbc96f74 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic_post.meta @@ -1,296 +1,3 @@ -[ccpp-table-properties] - name = GFS_DCNV_generic_pre - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_DCNV_generic_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = flag for 3d tracer diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[do_cnvgwd] - standard_name = flag_for_convective_gravity_wave_drag - long_name = flag for convective gravity wave drag (gwd) - units = flag - dimensions = () - type = logical - intent = in -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[gu0] - standard_name = x_wind_of_new_state - long_name = zonal wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gv0] - standard_name = y_wind_of_new_state - long_name = meridional wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = inout -[nsamftrac] - standard_name = number_of_tracers_for_samf - long_name = number of tracers for scale-aware mass flux schemes - units = count - dimensions = () - type = integer - intent = in -[ntqv] - standard_name = index_of_specific_humidity_in_tracer_concentration_array - long_name = tracer index for water vapor (specific humidity) - units = index - dimensions = () - type = integer - intent = in -[save_u] - standard_name = x_wind_save - long_name = x-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_v] - standard_name = y_wind_save - long_name = y-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_t] - standard_name = air_temperature_save - long_name = air temperature before entering a physics scheme - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_q] - standard_name = tracer_concentration_save - long_name = tracer concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[index_of_process_dcnv] - standard_name = index_of_deep_convection_process_process_in_cumulative_change_index - long_name = index of deep convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[cscnv] - standard_name = flag_for_Chikira_Sugiyama_deep_convection - long_name = flag for Chikira-Sugiyama convection - units = flag - dimensions = () - type = logical - intent = in -[satmedmf] - standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL - long_name = flag for scale-aware TKE moist EDMF PBL scheme - units = flag - dimensions = () - type = logical - intent = in -[trans_trac] - standard_name = flag_for_convective_transport_of_tracers - long_name = flag for convective transport of tracers - units = flag - dimensions = () - type = logical - intent = in -[ras] - standard_name = flag_for_relaxed_arakawa_schubert_deep_convection - long_name = flag for ras convection scheme - units = flag - dimensions = () - type = logical - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[ntclamt] - standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in -[ntrw] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[ntsw] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[ntrnc] - standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in -[ntsnc] - standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[ntgnc] - standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in -[nthl] - standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for hail - units = index - dimensions = () - type = integer - intent = in -[nthnc] - standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array - long_name = tracer index for hail number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgv] - standard_name = index_of_graupel_volume_in_tracer_concentration_array - long_name = tracer index for graupel particle volume - units = index - dimensions = () - type = integer - intent = in -[nthv] - standard_name = index_of_hail_volume_in_tracer_concentration_array - long_name = tracer index for hail particle volume - units = index - dimensions = () - type = integer - intent = in -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[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-table-properties] name = GFS_DCNV_generic_post diff --git a/physics/GFS_DCNV_generic_pre.F90 b/physics/GFS_DCNV_generic_pre.F90 new file mode 100644 index 000000000..e4eed29c9 --- /dev/null +++ b/physics/GFS_DCNV_generic_pre.F90 @@ -0,0 +1,90 @@ +!> \file GFS_DCNV_generic_pre.F90 +!! Contains code related to deep convective schemes to be used within the GFS physics suite. + + module GFS_DCNV_generic_pre + + contains + +!> \brief Interstitial scheme called prior to any deep convective scheme to save state variables for calculating tendencies after the deep convective scheme is executed +!! \section arg_table_GFS_DCNV_generic_pre_run Argument Table +!! \htmlinclude GFS_DCNV_generic_pre_run.html +!! + subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplchm, & + gu0, gv0, gt0, gq0, nsamftrac, ntqv, & + save_u, save_v, save_t, save_q, clw, & + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & + ntgnc, nthl, nthnc, nthv, ntgv, & + cscnv, satmedmf, trans_trac, ras, ntrac, & + dtidx, index_of_process_dcnv, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv + logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm + real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 + real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 + real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: gq0 + real(kind=kind_phys), dimension(:,:), intent(inout) :: save_u + real(kind=kind_phys), dimension(:,:), intent(inout) :: save_v + real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + logical, intent(in) :: cscnv, satmedmf, trans_trac, ras + real(kind=kind_phys), parameter :: zero = 0.0d0 + real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw + + integer :: i, k, n, tracers + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (ldiag3d) then + do k=1,levs + do i=1,im + save_t(i,k) = gt0(i,k) + save_u(i,k) = gu0(i,k) + save_v(i,k) = gv0(i,k) + enddo + enddo + elseif (do_cnvgwd) then + do k=1,levs + do i=1,im + save_t(i,k) = gt0(i,k) + enddo + enddo + endif + + if ((ldiag3d.and.qdiag3d) .or. cplchm) then + if (cscnv .or. satmedmf .or. trans_trac .or. ras) then + tracers = 2 + do n=2,ntrac + if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & + n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & + n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntgv ) then + tracers = tracers + 1 + if(dtidx(100+n,index_of_process_dcnv)>0) then + save_q(:,:,n) = clw(:,:,tracers) + endif + endif + enddo + else + do n=2,ntrac + if(dtidx(100+n,index_of_process_dcnv)>0) then + save_q(:,:,n) = gq0(:,:,n) + endif + enddo + endif ! end if_ras or cfscnv or samf + save_q(:,:,ntqv) = gq0(:,:,ntqv) + endif + + end subroutine GFS_DCNV_generic_pre_run + + end module GFS_DCNV_generic_pre \ No newline at end of file diff --git a/physics/GFS_DCNV_generic_pre.meta b/physics/GFS_DCNV_generic_pre.meta new file mode 100644 index 000000000..e1cf1b022 --- /dev/null +++ b/physics/GFS_DCNV_generic_pre.meta @@ -0,0 +1,292 @@ +[ccpp-table-properties] + name = GFS_DCNV_generic_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_DCNV_generic_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[do_cnvgwd] + standard_name = flag_for_convective_gravity_wave_drag + long_name = flag for convective gravity wave drag (gwd) + units = flag + dimensions = () + type = logical + intent = in +[cplchm] + standard_name = flag_for_chemistry_coupling + long_name = flag controlling cplchm collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[gu0] + standard_name = x_wind_of_new_state + long_name = zonal wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gv0] + standard_name = y_wind_of_new_state + long_name = meridional wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[nsamftrac] + standard_name = number_of_tracers_for_samf + long_name = number of tracers for scale-aware mass flux schemes + units = count + dimensions = () + type = integer + intent = in +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[save_u] + standard_name = x_wind_save + long_name = x-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_v] + standard_name = y_wind_save + long_name = y-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_t] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_q] + standard_name = tracer_concentration_save + long_name = tracer concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_process_dcnv] + standard_name = index_of_deep_convection_process_process_in_cumulative_change_index + long_name = index of deep convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[cscnv] + standard_name = flag_for_Chikira_Sugiyama_deep_convection + long_name = flag for Chikira-Sugiyama convection + units = flag + dimensions = () + type = logical + intent = in +[satmedmf] + standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL + long_name = flag for scale-aware TKE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in +[trans_trac] + standard_name = flag_for_convective_transport_of_tracers + long_name = flag for convective transport of tracers + units = flag + dimensions = () + type = logical + intent = in +[ras] + standard_name = flag_for_relaxed_arakawa_schubert_deep_convection + long_name = flag for ras convection scheme + units = flag + dimensions = () + type = logical + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[ntclamt] + standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgl] + standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in +[ntgnc] + standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[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 \ No newline at end of file diff --git a/physics/GFS_GWD_generic_post.F90 b/physics/GFS_GWD_generic_post.F90 new file mode 100644 index 000000000..b3538c2b0 --- /dev/null +++ b/physics/GFS_GWD_generic_post.F90 @@ -0,0 +1,67 @@ +!> This module contains the CCPP-compliant orographic gravity wave drag post +!! interstitial codes. +module GFS_GWD_generic_post + +contains + +!! \section arg_table_GFS_GWD_generic_post_run Argument Table +!! \htmlinclude GFS_GWD_generic_post_run.html +!! +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + subroutine GFS_GWD_generic_post_run(lssav, ldiag3d, dtf, dusfcg, dvsfcg, dudt, dvdt, dtdt, & + & dugwd, dvgwd, flag_for_gwd_generic_tend, dtend, dtidx, index_of_temperature, index_of_x_wind, & + & index_of_y_wind, index_of_process_orographic_gwd, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + logical, intent(in) :: lssav, ldiag3d, flag_for_gwd_generic_tend + + real(kind=kind_phys), intent(in) :: dusfcg(:), dvsfcg(:) + real(kind=kind_phys), intent(in) :: dudt(:,:), dvdt(:,:), dtdt(:,:) + real(kind=kind_phys), intent(in) :: dtf + + real(kind=kind_phys), intent(inout) :: dugwd(:), dvgwd(:) + + ! dtend only allocated only if ldiag3d is .true. + real(kind=kind_phys), intent(inout) :: dtend(:,:,:) + integer, intent(in) :: dtidx(:,:), index_of_temperature, & + & index_of_x_wind, index_of_y_wind, index_of_process_orographic_gwd + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: idtend + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (lssav) then + dugwd(:) = dugwd(:) + dusfcg(:)*dtf + dvgwd(:) = dvgwd(:) + dvsfcg(:)*dtf + + if (ldiag3d .and. flag_for_gwd_generic_tend) then + idtend = dtidx(index_of_temperature, index_of_process_orographic_gwd) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + dtdt*dtf + endif + + idtend = dtidx(index_of_x_wind, index_of_process_orographic_gwd) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + dudt*dtf + endif + + idtend = dtidx(index_of_y_wind, index_of_process_orographic_gwd) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + dvdt*dtf + endif + endif + endif + + end subroutine GFS_GWD_generic_post_run +!> @} + +end module GFS_GWD_generic_post diff --git a/physics/GFS_GWD_generic_post.meta b/physics/GFS_GWD_generic_post.meta new file mode 100644 index 000000000..204c16c84 --- /dev/null +++ b/physics/GFS_GWD_generic_post.meta @@ -0,0 +1,153 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_GWD_generic_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_GWD_generic_post_run + type = scheme +[lssav] + standard_name = flag_for_diagnostics + long_name = flag for calculating diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for calculating 3-D diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[dtf] + standard_name = timestep_for_dynamics + long_name = dynamics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[dusfcg] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dvsfcg] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dudt] + standard_name = process_split_cumulative_tendency_of_x_wind + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dvdt] + standard_name = process_split_cumulative_tendency_of_y_wind + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dtdt] + standard_name = process_split_cumulative_tendency_of_air_temperature + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dugwd] + standard_name = time_integral_of_x_stress_due_to_gravity_wave_drag + long_name = integral over time of zonal stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[dvgwd] + standard_name = time_integral_of_y_stress_due_to_gravity_wave_drag + long_name = integral over time of meridional stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = inout +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_temperature] + standard_name = index_of_temperature_in_cumulative_change_index + long_name = index of temperature in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_x_wind] + standard_name = index_of_x_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_y_wind] + standard_name = index_of_y_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_orographic_gwd] + standard_name = index_of_orographic_gravity_wave_drag_process_in_cumulative_change_index + long_name = index of orographic gravity wave drag process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[flag_for_gwd_generic_tend] + standard_name = flag_for_generic_tendency_due_to_gravity_wave_drag + long_name = true if GFS_GWD_generic should calculate tendencies + 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 \ No newline at end of file diff --git a/physics/GFS_GWD_generic.F90 b/physics/GFS_GWD_generic_pre.F90 similarity index 60% rename from physics/GFS_GWD_generic.F90 rename to physics/GFS_GWD_generic_pre.F90 index a2c869e6a..1c355cc06 100644 --- a/physics/GFS_GWD_generic.F90 +++ b/physics/GFS_GWD_generic_pre.F90 @@ -1,4 +1,4 @@ -!> \file GFS_GWD_generic.F90 +!> \file GFS_GWD_generic_pre.F90 !! This file contains the CCPP-compliant orographic gravity wave !! drag pre interstitial codes. @@ -6,12 +6,6 @@ module GFS_GWD_generic_pre contains -!! \section arg_table_GFS_GWD_generic_pre_init Argument Table -!! \htmlinclude GFS_GWD_generic_pre_init.html -!! - subroutine GFS_GWD_generic_pre_init() - end subroutine GFS_GWD_generic_pre_init - !! \section arg_table_GFS_GWD_generic_pre_run Argument Table !! \htmlinclude GFS_GWD_generic_pre_run.html !! @@ -144,88 +138,4 @@ subroutine GFS_GWD_generic_pre_run( & end subroutine GFS_GWD_generic_pre_run !> @} -!! \section arg_table_GFS_GWD_generic_pre_finalize Argument Table -!! \htmlinclude GFS_GWD_generic_pre_finalize.html -!! - subroutine GFS_GWD_generic_pre_finalize() - end subroutine GFS_GWD_generic_pre_finalize - -end module GFS_GWD_generic_pre - -!> This module contains the CCPP-compliant orographic gravity wave drag post -!! interstitial codes. -module GFS_GWD_generic_post - -contains - - - subroutine GFS_GWD_generic_post_init() - end subroutine GFS_GWD_generic_post_init - -!! \section arg_table_GFS_GWD_generic_post_run Argument Table -!! \htmlinclude GFS_GWD_generic_post_run.html -!! -!! \section general General Algorithm -!! \section detailed Detailed Algorithm -!! @{ - subroutine GFS_GWD_generic_post_run(lssav, ldiag3d, dtf, dusfcg, dvsfcg, dudt, dvdt, dtdt, & - & dugwd, dvgwd, flag_for_gwd_generic_tend, dtend, dtidx, index_of_temperature, index_of_x_wind, & - & index_of_y_wind, index_of_process_orographic_gwd, errmsg, errflg) - - use machine, only : kind_phys - implicit none - - logical, intent(in) :: lssav, ldiag3d, flag_for_gwd_generic_tend - - real(kind=kind_phys), intent(in) :: dusfcg(:), dvsfcg(:) - real(kind=kind_phys), intent(in) :: dudt(:,:), dvdt(:,:), dtdt(:,:) - real(kind=kind_phys), intent(in) :: dtf - - real(kind=kind_phys), intent(inout) :: dugwd(:), dvgwd(:) - - ! dtend only allocated only if ldiag3d is .true. - real(kind=kind_phys), intent(inout) :: dtend(:,:,:) - integer, intent(in) :: dtidx(:,:), index_of_temperature, & - & index_of_x_wind, index_of_y_wind, index_of_process_orographic_gwd - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: idtend - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (lssav) then - dugwd(:) = dugwd(:) + dusfcg(:)*dtf - dvgwd(:) = dvgwd(:) + dvsfcg(:)*dtf - - if (ldiag3d .and. flag_for_gwd_generic_tend) then - idtend = dtidx(index_of_temperature, index_of_process_orographic_gwd) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + dtdt*dtf - endif - - idtend = dtidx(index_of_x_wind, index_of_process_orographic_gwd) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + dudt*dtf - endif - - idtend = dtidx(index_of_y_wind, index_of_process_orographic_gwd) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + dvdt*dtf - endif - endif - endif - - end subroutine GFS_GWD_generic_post_run -!> @} - -!! \section arg_table_GFS_GWD_generic_post_finalize Argument Table -!! \htmlinclude GFS_GWD_generic_post_finalize.html -!! - subroutine GFS_GWD_generic_post_finalize() - end subroutine GFS_GWD_generic_post_finalize - -end module GFS_GWD_generic_post +end module GFS_GWD_generic_pre \ No newline at end of file diff --git a/physics/GFS_GWD_generic.meta b/physics/GFS_GWD_generic_pre.meta similarity index 60% rename from physics/GFS_GWD_generic.meta rename to physics/GFS_GWD_generic_pre.meta index 78b2ee970..9bcc03300 100644 --- a/physics/GFS_GWD_generic.meta +++ b/physics/GFS_GWD_generic_pre.meta @@ -234,158 +234,4 @@ units = 1 dimensions = () type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_GWD_generic_post - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_GWD_generic_post_run - type = scheme -[lssav] - standard_name = flag_for_diagnostics - long_name = flag for calculating diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for calculating 3-D diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[dtf] - standard_name = timestep_for_dynamics - long_name = dynamics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[dusfcg] - standard_name = instantaneous_x_stress_due_to_gravity_wave_drag - long_name = zonal surface stress due to orographic gravity wave drag - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dvsfcg] - standard_name = instantaneous_y_stress_due_to_gravity_wave_drag - long_name = meridional surface stress due to orographic gravity wave drag - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dudt] - standard_name = process_split_cumulative_tendency_of_x_wind - long_name = zonal wind tendency due to model physics - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dvdt] - standard_name = process_split_cumulative_tendency_of_y_wind - long_name = meridional wind tendency due to model physics - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dtdt] - standard_name = process_split_cumulative_tendency_of_air_temperature - long_name = air temperature tendency due to model physics - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dugwd] - standard_name = time_integral_of_x_stress_due_to_gravity_wave_drag - long_name = integral over time of zonal stress due to gravity wave drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[dvgwd] - standard_name = time_integral_of_y_stress_due_to_gravity_wave_drag - long_name = integral over time of meridional stress due to gravity wave drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[index_of_temperature] - standard_name = index_of_temperature_in_cumulative_change_index - long_name = index of temperature in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_x_wind] - standard_name = index_of_x_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_y_wind] - standard_name = index_of_y_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_orographic_gwd] - standard_name = index_of_orographic_gravity_wave_drag_process_in_cumulative_change_index - long_name = index of orographic gravity wave drag process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[flag_for_gwd_generic_tend] - standard_name = flag_for_generic_tendency_due_to_gravity_wave_drag - long_name = true if GFS_GWD_generic should calculate tendencies - 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 + intent = out \ No newline at end of file diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic_post.F90 similarity index 88% rename from physics/GFS_MP_generic.F90 rename to physics/GFS_MP_generic_post.F90 index e106cb908..a7be0ab4c 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -1,71 +1,6 @@ -!> \file GFS_MP_generic.F90 +!> \file GFS_MP_generic_post.F90 !! This file contains the subroutines that calculate diagnotics variables -!! before/after calling any microphysics scheme: - -!> This module contains the CCPP-compliant MP generic pre interstitial codes. - module GFS_MP_generic_pre - contains - - subroutine GFS_MP_generic_pre_init() - end subroutine GFS_MP_generic_pre_init - -!> \section arg_table_GFS_MP_generic_pre_run Argument Table -!! \htmlinclude GFS_MP_generic_pre_run.html -!! - subroutine GFS_MP_generic_pre_run(im, levs, ldiag3d, qdiag3d, do_aw, ntcw, nncl, & - ntrac, gt0, gq0, save_t, save_q, num_dfi_radar, errmsg, errflg) -! - use machine, only: kind_phys - - implicit none - integer, intent(in) :: im, levs, ntcw, nncl, ntrac, num_dfi_radar - logical, intent(in) :: ldiag3d, qdiag3d, do_aw - real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 - real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0 - - real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k, n - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (ldiag3d .or. do_aw .or. num_dfi_radar>0) then - do k=1,levs - do i=1,im - save_t(i,k) = gt0(i,k) - enddo - enddo - endif - if (ldiag3d .or. do_aw) then - if(qdiag3d) then - do n=1,ntrac - do k=1,levs - do i=1,im - save_q(i,k,n) = gq0(i,k,n) - enddo - enddo - enddo - else if(do_aw) then - ! if qdiag3d, all q are saved already - save_q(1:im,:,1) = gq0(1:im,:,1) - do n=ntcw,ntcw+nncl-1 - save_q(1:im,:,n) = gq0(1:im,:,n) - enddo - endif - endif - - end subroutine GFS_MP_generic_pre_run - - subroutine GFS_MP_generic_pre_finalize() - end subroutine GFS_MP_generic_pre_finalize - - end module GFS_MP_generic_pre +!! after calling any microphysics scheme: !> This module contains the subroutine that calculates !! precipitation type and its post, which provides precipitation forcing @@ -73,9 +8,6 @@ end module GFS_MP_generic_pre module GFS_MP_generic_post contains - subroutine GFS_MP_generic_post_init() - end subroutine GFS_MP_generic_post_init - !>\defgroup gfs_calpreciptype GFS Precipitation Type Diagnostics Module !! \brief If dominant precip type is requested (i.e., Zhao-Carr MP scheme), 4 more algorithms in calpreciptype() !! will be called. the tallies are then summed in calwxt_dominant(). For GFDL cloud MP scheme, determine convective @@ -459,7 +391,4 @@ subroutine GFS_MP_generic_post_run( end subroutine GFS_MP_generic_post_run !> @} - subroutine GFS_MP_generic_post_finalize() - end subroutine GFS_MP_generic_post_finalize - end module GFS_MP_generic_post diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic_post.meta similarity index 86% rename from physics/GFS_MP_generic.meta rename to physics/GFS_MP_generic_post.meta index 6177b1344..6b0f6cc0a 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic_post.meta @@ -1,123 +1,3 @@ -[ccpp-table-properties] - name = GFS_MP_generic_pre - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_MP_generic_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = logical flag for 3D diagnostics - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = logical flag for 3D tracer diagnostics - units = flag - dimensions = () - type = logical - intent = in -[do_aw] - standard_name = flag_for_Arakawa_Wu_adjustment - long_name = flag for Arakawa Wu scale-aware adjustment - units = flag - dimensions = () - type = logical - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[nncl] - standard_name = number_of_condensate_species - long_name = number of cloud condensate types - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[save_t] - standard_name = air_temperature_save - long_name = air temperature before entering a physics scheme - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_q] - standard_name = tracer_concentration_save - long_name = tracer concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = inout -[num_dfi_radar] - standard_name = number_of_radar_derived_temperature_or_convection_suppression_intervals - long_name = number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression - units = count - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-table-properties] name = GFS_MP_generic_post diff --git a/physics/GFS_MP_generic_pre.F90 b/physics/GFS_MP_generic_pre.F90 new file mode 100644 index 000000000..0910f9cd2 --- /dev/null +++ b/physics/GFS_MP_generic_pre.F90 @@ -0,0 +1,62 @@ +!> \file GFS_MP_generic_pre.F90 +!! This file contains the subroutines that calculate diagnotics variables +!! before calling any microphysics scheme: + +!> This module contains the CCPP-compliant MP generic pre interstitial codes. + module GFS_MP_generic_pre + contains + +!> \section arg_table_GFS_MP_generic_pre_run Argument Table +!! \htmlinclude GFS_MP_generic_pre_run.html +!! + subroutine GFS_MP_generic_pre_run(im, levs, ldiag3d, qdiag3d, do_aw, ntcw, nncl, & + ntrac, gt0, gq0, save_t, save_q, num_dfi_radar, errmsg, errflg) +! + use machine, only: kind_phys + + implicit none + integer, intent(in) :: im, levs, ntcw, nncl, ntrac, num_dfi_radar + logical, intent(in) :: ldiag3d, qdiag3d, do_aw + real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 + real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0 + + real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k, n + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (ldiag3d .or. do_aw .or. num_dfi_radar>0) then + do k=1,levs + do i=1,im + save_t(i,k) = gt0(i,k) + enddo + enddo + endif + if (ldiag3d .or. do_aw) then + if(qdiag3d) then + do n=1,ntrac + do k=1,levs + do i=1,im + save_q(i,k,n) = gq0(i,k,n) + enddo + enddo + enddo + else if(do_aw) then + ! if qdiag3d, all q are saved already + save_q(1:im,:,1) = gq0(1:im,:,1) + do n=ntcw,ntcw+nncl-1 + save_q(1:im,:,n) = gq0(1:im,:,n) + enddo + endif + endif + + end subroutine GFS_MP_generic_pre_run + + end module GFS_MP_generic_pre \ No newline at end of file diff --git a/physics/GFS_MP_generic_pre.meta b/physics/GFS_MP_generic_pre.meta new file mode 100644 index 000000000..ac0393917 --- /dev/null +++ b/physics/GFS_MP_generic_pre.meta @@ -0,0 +1,119 @@ +[ccpp-table-properties] + name = GFS_MP_generic_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_MP_generic_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = logical flag for 3D diagnostics + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = logical flag for 3D tracer diagnostics + units = flag + dimensions = () + type = logical + intent = in +[do_aw] + standard_name = flag_for_Arakawa_Wu_adjustment + long_name = flag for Arakawa Wu scale-aware adjustment + units = flag + dimensions = () + type = logical + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[nncl] + standard_name = number_of_condensate_species + long_name = number of cloud condensate types + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[save_t] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_q] + standard_name = tracer_concentration_save + long_name = tracer concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[num_dfi_radar] + standard_name = number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_PBL_generic_common.F90 b/physics/GFS_PBL_generic_common.F90 new file mode 100644 index 000000000..9b3f83b57 --- /dev/null +++ b/physics/GFS_PBL_generic_common.F90 @@ -0,0 +1,73 @@ +!> \file GFS_PBL_generic_common.F90 +!! Contains code used in both pre/post PBL-related interstitial schemes to be used within the GFS physics suite. + + module GFS_PBL_generic_common + + implicit none + + private + + public :: set_aerosol_tracer_index + + contains + + subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & + imp_physics_thompson, ltaerosol, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & + errmsg, errflg) + implicit none + ! + integer, intent(in ) :: imp_physics, imp_physics_wsm6, & + imp_physics_thompson, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr,imp_physics_nssl + logical, intent(in ) :: ltaerosol, nssl_hail_on, nssl_ccn_on + integer, intent(out) :: kk + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errflg = 0 + +! Set Interstitial%kk = last index in diffused tracer array before chemistry-aerosol tracers + if (imp_physics == imp_physics_wsm6) then +! WSM6 + kk = 4 + elseif (imp_physics == imp_physics_thompson) then +! Thompson + if(ltaerosol) then + kk = 12 + else + kk = 9 + endif +! MG + elseif (imp_physics == imp_physics_mg) then + if (ntgl > 0) then + kk = 12 + else + kk = 10 + endif + elseif (imp_physics == imp_physics_gfdl) then +! GFDL MP + kk = 7 + elseif (imp_physics == imp_physics_zhao_carr) then +! Zhao/Carr/Sundqvist + kk = 3 + elseif (imp_physics == imp_physics_nssl) then + IF ( nssl_hail_on ) THEN + kk = 16 + ELSE + kk = 13 + ENDIF + IF ( nssl_ccn_on ) kk = kk + 1 + else + write(errmsg,'(*(a))') 'Logic error: unknown microphysics option in set_aerosol_tracer_index' + kk = -999 + errflg = 1 + return + endif + + end subroutine set_aerosol_tracer_index + + end module GFS_PBL_generic_common \ No newline at end of file diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic_post.F90 similarity index 56% rename from physics/GFS_PBL_generic.F90 rename to physics/GFS_PBL_generic_post.F90 index 8d013a442..1f84252b2 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic_post.F90 @@ -1,393 +1,10 @@ -!> \file GFS_PBL_generic.F90 -!! Contains code related to PBL schemes to be used within the GFS physics suite. - - module GFS_PBL_generic_common - - implicit none - - private - - public :: set_aerosol_tracer_index - - contains - - subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & - imp_physics_thompson, ltaerosol, & - imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, imp_physics_nssl,& - nssl_hail_on, nssl_ccn_on, kk, & - errmsg, errflg) - implicit none - ! - integer, intent(in ) :: imp_physics, imp_physics_wsm6, & - imp_physics_thompson, & - imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr,imp_physics_nssl - logical, intent(in ) :: ltaerosol, nssl_hail_on, nssl_ccn_on - integer, intent(out) :: kk - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errflg = 0 - -! Set Interstitial%kk = last index in diffused tracer array before chemistry-aerosol tracers - if (imp_physics == imp_physics_wsm6) then -! WSM6 - kk = 4 - elseif (imp_physics == imp_physics_thompson) then -! Thompson - if(ltaerosol) then - kk = 12 - else - kk = 9 - endif -! MG - elseif (imp_physics == imp_physics_mg) then - if (ntgl > 0) then - kk = 12 - else - kk = 10 - endif - elseif (imp_physics == imp_physics_gfdl) then -! GFDL MP - kk = 7 - elseif (imp_physics == imp_physics_zhao_carr) then -! Zhao/Carr/Sundqvist - kk = 3 - elseif (imp_physics == imp_physics_nssl) then - IF ( nssl_hail_on ) THEN - kk = 16 - ELSE - kk = 13 - ENDIF - IF ( nssl_ccn_on ) kk = kk + 1 - else - write(errmsg,'(*(a))') 'Logic error: unknown microphysics option in set_aerosol_tracer_index' - kk = -999 - errflg = 1 - return - endif - - end subroutine set_aerosol_tracer_index - - end module GFS_PBL_generic_common - - - module GFS_PBL_generic_pre - - contains - - subroutine GFS_PBL_generic_pre_init () - end subroutine GFS_PBL_generic_pre_init - - subroutine GFS_PBL_generic_pre_finalize() - end subroutine GFS_PBL_generic_pre_finalize - -!> \brief This scheme sets up the vertically diffused tracer array for any PBL scheme based on the microphysics scheme chosen -!! \section arg_table_GFS_PBL_generic_pre_run Argument Table -!! \htmlinclude GFS_PBL_generic_pre_run.html -!! - subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, & - ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, & - ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & - ntccn, nthl, nthnc, ntgv, nthv, & - imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, imp_physics_nssl, & - ltaerosol, nssl_ccn_on, nssl_hail_on, & - hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & - flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) - - use machine, only : kind_phys - use GFS_PBL_generic_common, only : set_aerosol_tracer_index - - implicit none - - integer, parameter :: kp = kind_phys - integer, intent(out) :: rtg_ozone_index - integer, intent(in) :: im, levs, nvdiff, ntrac - integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc - integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm - integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv - logical, intent(in) :: trans_aero, ldiag3d, qdiag3d, lssav - integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 - integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires - logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend - integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: nssl_hail_on, nssl_ccn_on - - real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs - real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs - real(kind=kind_phys), dimension(:,:, :), intent(inout) :: vdftra - real(kind=kind_phys), dimension(:,:), intent(out) :: save_u, save_v, save_t - real(kind=kind_phys), dimension(:,:, :), intent(out) :: save_q - - ! CCPP error handling variables - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - real (kind=kind_phys), parameter :: zero = 0.0_kp, one=1.0_kp - - ! Local variables - integer :: i, k, kk, k1, n - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - rtg_ozone_index=-1 -!DH: dvdftra is only used if nvdiff != ntrac or (nvdiff == ntrac .and. ) - if (nvdiff == ntrac .and. (hybedmf .or. do_shoc .or. satmedmf)) then - vdftra = qgrs - rtg_ozone_index = ntoz - else - if (imp_physics == imp_physics_wsm6) then - ! WSM6 - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 4 - - ! Ferrier-Aligo - elseif (imp_physics == imp_physics_fer_hires) then - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,nqrimef) - vdftra(i,k,6) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 6 - - elseif (imp_physics == imp_physics_thompson) then - ! Thompson - if(ltaerosol) then - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntgl) - vdftra(i,k,7) = qgrs(i,k,ntlnc) - vdftra(i,k,8) = qgrs(i,k,ntinc) - vdftra(i,k,9) = qgrs(i,k,ntrnc) - vdftra(i,k,10) = qgrs(i,k,ntoz) - vdftra(i,k,11) = qgrs(i,k,ntwa) - vdftra(i,k,12) = qgrs(i,k,ntia) - enddo - enddo - rtg_ozone_index = 10 - else - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntgl) - vdftra(i,k,7) = qgrs(i,k,ntinc) - vdftra(i,k,8) = qgrs(i,k,ntrnc) - vdftra(i,k,9) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 9 - endif - ! MG - elseif (imp_physics == imp_physics_mg) then ! MG3/2 - if (ntgl > 0) then ! MG3 - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntgl) - vdftra(i,k,7) = qgrs(i,k,ntlnc) - vdftra(i,k,8) = qgrs(i,k,ntinc) - vdftra(i,k,9) = qgrs(i,k,ntrnc) - vdftra(i,k,10) = qgrs(i,k,ntsnc) - vdftra(i,k,11) = qgrs(i,k,ntgnc) - vdftra(i,k,12) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 12 - else ! MG2 - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntlnc) - vdftra(i,k,7) = qgrs(i,k,ntinc) - vdftra(i,k,8) = qgrs(i,k,ntrnc) - vdftra(i,k,9) = qgrs(i,k,ntsnc) - vdftra(i,k,10) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 10 - endif - elseif (imp_physics == imp_physics_gfdl) then - ! GFDL MP - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntgl) - vdftra(i,k,7) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 7 - elseif (imp_physics == imp_physics_zhao_carr) then -! Zhao/Carr/Sundqvist - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 3 - elseif (imp_physics == imp_physics_nssl ) then - ! nssl - IF ( nssl_hail_on ) THEN - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntgl) - vdftra(i,k,7) = qgrs(i,k,nthl) - vdftra(i,k,8) = qgrs(i,k,ntlnc) - vdftra(i,k,9) = qgrs(i,k,ntinc) - vdftra(i,k,10) = qgrs(i,k,ntrnc) - vdftra(i,k,11) = qgrs(i,k,ntsnc) - vdftra(i,k,12) = qgrs(i,k,ntgnc) - vdftra(i,k,13) = qgrs(i,k,nthnc) - vdftra(i,k,14) = qgrs(i,k,ntgv) - vdftra(i,k,15) = qgrs(i,k,nthv) - vdftra(i,k,16) = qgrs(i,k,ntoz) - IF ( nssl_ccn_on ) THEN - vdftra(i,k,17) = qgrs(i,k,ntccn) - ENDIF - enddo - enddo - - ELSE - ! no hail - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntgl) - vdftra(i,k,7) = qgrs(i,k,ntlnc) - vdftra(i,k,8) = qgrs(i,k,ntinc) - vdftra(i,k,9) = qgrs(i,k,ntrnc) - vdftra(i,k,10) = qgrs(i,k,ntsnc) - vdftra(i,k,11) = qgrs(i,k,ntgnc) - vdftra(i,k,12) = qgrs(i,k,ntgv) - vdftra(i,k,13) = qgrs(i,k,ntoz) - IF ( nssl_ccn_on ) THEN - vdftra(i,k,14) = qgrs(i,k,ntccn) - ENDIF - enddo - enddo - - ENDIF - - - endif -! - if (trans_aero) then - call set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & - imp_physics_thompson, ltaerosol, & - imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, imp_physics_nssl,& - nssl_hail_on, nssl_ccn_on, kk, & - errmsg, errflg) - if (errflg /= 0) return - ! - k1 = kk - do n=ntchs,ntchm+ntchs-1 - k1 = k1 + 1 - do k=1,levs - do i=1,im - vdftra(i,k,k1) = qgrs(i,k,n) - enddo - enddo - enddo - endif -! - if (ntke>0) then - do k=1,levs - do i=1,im - vdftra(i,k,ntkev) = qgrs(i,k,ntke) - enddo - enddo - endif -! - endif - - if(ldiag3d .and. lssav .and. flag_for_pbl_generic_tend) then - do k=1,levs - do i=1,im - save_t(i,k) = tgrs(i,k) - save_u(i,k) = ugrs(i,k) - save_v(i,k) = vgrs(i,k) - enddo - enddo - if(qdiag3d) then - do k=1,levs - do i=1,im - save_q(i,k,ntqv) = qgrs(i,k,ntqv) - save_q(i,k,ntoz) = qgrs(i,k,ntoz) - enddo - enddo - if(ntke>0) then - do k=1,levs - do i=1,im - save_q(i,k,ntke) = qgrs(i,k,ntke) - enddo - enddo - endif - endif - endif - - end subroutine GFS_PBL_generic_pre_run - - end module GFS_PBL_generic_pre - +!> \file GFS_PBL_generic_post.F90 +!! Contains code related to PBL schemes to be called after PBL schemes within GFS-based physics suites. module GFS_PBL_generic_post contains - subroutine GFS_PBL_generic_post_init () - end subroutine GFS_PBL_generic_post_init - - subroutine GFS_PBL_generic_post_finalize () - end subroutine GFS_PBL_generic_post_finalize - !> \section arg_table_GFS_PBL_generic_post_run Argument Table !! \htmlinclude GFS_PBL_generic_post_run.html !! diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic_post.meta similarity index 69% rename from physics/GFS_PBL_generic.meta rename to physics/GFS_PBL_generic_post.meta index 9e0d68a7d..08a38800f 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic_post.meta @@ -1,441 +1,8 @@ -[ccpp-table-properties] - name = GFS_PBL_generic_pre - type = scheme - dependencies = GFS_PBL_generic.F90,machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_PBL_generic_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[nvdiff] - standard_name = number_of_vertical_diffusion_tracers - long_name = number of tracers to diffuse vertically - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[rtg_ozone_index] - standard_name = vertically_diffused_tracer_index_of_ozone - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = out -[ntqv] - standard_name = index_of_specific_humidity_in_tracer_concentration_array - long_name = tracer index for water vapor (specific humidity) - units = index - dimensions = () - type = integer - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[ntrw] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[ntsw] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[ntlnc] - standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array - long_name = tracer index for liquid number concentration - units = index - dimensions = () - type = integer - intent = in -[ntinc] - standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array - long_name = tracer index for ice number concentration - units = index - dimensions = () - type = integer - intent = in -[ntrnc] - standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in -[ntsnc] - standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgnc] - standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in -[ntwa] - standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array - long_name = tracer index for water friendly aerosol - units = index - dimensions = () - type = integer - intent = in -[ntia] - standard_name = index_of_mass_number_concentration_of_nonhygroscopic_ice_nucleating_aerosols_in_tracer_concentration_array - long_name = tracer index for ice friendly aerosol - units = index - dimensions = () - type = integer - intent = in -[ntgl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in -[ntke] - standard_name = index_of_turbulent_kinetic_energy_in_tracer_concentration_array - long_name = tracer index for turbulent kinetic energy - units = index - dimensions = () - type = integer - intent = in -[ntkev] - standard_name = index_for_turbulent_kinetic_energy_vertical_diffusion_tracer - long_name = index for turbulent kinetic energy in the vertically diffused tracer array - units = index - dimensions = () - type = integer - intent = in -[nqrimef] - standard_name = index_of_mass_weighted_rime_factor_in_tracer_concentration_array - long_name = tracer index for mass weighted rime factor - units = index - dimensions = () - type = integer - intent = in -[trans_aero] - standard_name = flag_for_aerosol_convective_transport_and_PBL_diffusion - long_name = flag for aerosol convective transport and PBL diffusion - units = flag - dimensions = () - type = logical - intent = in -[ntchs] - standard_name = index_of_first_chemical_tracer_in_tracer_concentration_array - long_name = tracer index for first chemical tracer - units = index - dimensions = () - type = integer - intent = in -[ntchm] - standard_name = number_of_chemical_tracers - long_name = number of chemical tracers - units = count - dimensions = () - type = integer - intent = in -[ntccn] - standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array - long_name = tracer index for cloud condensation nuclei number concentration - units = index - dimensions = () - type = integer - intent = in -[nthl] - standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for hail - units = index - dimensions = () - type = integer - intent = in -[nthnc] - standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array - long_name = tracer index for hail number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgv] - standard_name = index_of_graupel_volume_in_tracer_concentration_array - long_name = tracer index for graupel particle volume - units = index - dimensions = () - type = integer - intent = in -[nthv] - standard_name = index_of_hail_volume_in_tracer_concentration_array - long_name = tracer index for hail particle volume - units = index - dimensions = () - type = integer - intent = in -[imp_physics] - standard_name = control_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_gfdl] - standard_name = identifier_for_gfdl_microphysics_scheme - long_name = choice of GFDL microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_thompson] - standard_name = identifier_for_thompson_microphysics_scheme - long_name = choice of Thompson microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_wsm6] - standard_name = identifier_for_wsm6_microphysics_scheme - long_name = choice of WSM6 microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_zhao_carr] - standard_name = identifier_for_zhao_carr_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_mg] - standard_name = identifier_for_morrison_gettelman_microphysics_scheme - long_name = choice of Morrison-Gettelman microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_fer_hires] - standard_name = identifier_for_fer_hires_microphysics_scheme - long_name = choice of Ferrier-Aligo microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_nssl] - standard_name = identifier_for_nssl_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[ltaerosol] - standard_name = flag_for_aerosol_physics - long_name = flag for aerosol physics - units = flag - dimensions = () - type = logical - intent = in -[nssl_ccn_on] - standard_name = nssl_ccn_on - long_name = CCN activation flag in NSSL micro - units = flag - dimensions = () - type = logical - intent = in -[nssl_hail_on] - standard_name = nssl_hail_on - long_name = hail activation flag in NSSL micro - units = flag - dimensions = () - type = logical - intent = in -[hybedmf] - standard_name = flag_for_hybrid_edmf_pbl_scheme - long_name = flag for hybrid edmf pbl scheme (moninedmf) - units = flag - dimensions = () - type = logical - intent = in -[do_shoc] - standard_name = flag_for_shoc - long_name = flag for SHOC - units = flag - dimensions = () - type = logical - intent = in -[satmedmf] - standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL - long_name = flag for scale-aware TKE moist EDMF PBL scheme - units = flag - dimensions = () - type = logical - intent = in -[qgrs] - standard_name = tracer_concentration - long_name = model layer mean tracer concentration - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[vdftra] - standard_name = vertically_diffused_tracer_concentration - long_name = tracer concentration diffused by PBL scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) - type = real - kind = kind_phys - intent = inout -[save_u] - standard_name = x_wind_save - long_name = x-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[save_v] - standard_name = y_wind_save - long_name = y-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[save_t] - standard_name = air_temperature_save - long_name = air temperature before entering a physics scheme - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[save_q] - standard_name = tracer_concentration_save - long_name = tracer concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = out -[flag_for_pbl_generic_tend] - standard_name = flag_for_generic_tendency_due_to_planetary_boundary_layer - long_name = true if GFS_PBL_generic should calculate tendencies - units = flag - dimensions = () - type = logical - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = flag for 3d tracer diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[lssav] - standard_name = flag_for_diagnostics - long_name = logical flag for storing diagnostics - units = flag - dimensions = () - type = logical - intent = in -[ugrs] - standard_name = x_wind - long_name = zonal wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vgrs] - standard_name = y_wind - long_name = meridional wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - 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-table-properties] name = GFS_PBL_generic_post type = scheme - dependencies = GFS_PBL_generic.F90,machine.F + dependencies = GFS_PBL_generic_common.F90,machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_PBL_generic_pre.F90 b/physics/GFS_PBL_generic_pre.F90 new file mode 100644 index 000000000..0dbdf7225 --- /dev/null +++ b/physics/GFS_PBL_generic_pre.F90 @@ -0,0 +1,300 @@ +!> \file GFS_PBL_generic_pre.F90 +!! Contains code related to PBL schemes to be called prior to PBL schemes within GFS-based physics suites. + + module GFS_PBL_generic_pre + + contains + +!> \brief This scheme sets up the vertically diffused tracer array for any PBL scheme based on the microphysics scheme chosen +!! \section arg_table_GFS_PBL_generic_pre_run Argument Table +!! \htmlinclude GFS_PBL_generic_pre_run.html +!! + subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, & + ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, & + ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & + ntccn, nthl, nthnc, ntgv, nthv, & + imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & + imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, imp_physics_nssl, & + ltaerosol, nssl_ccn_on, nssl_hail_on, & + hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & + flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) + + use machine, only : kind_phys + use GFS_PBL_generic_common, only : set_aerosol_tracer_index + + implicit none + + integer, parameter :: kp = kind_phys + integer, intent(out) :: rtg_ozone_index + integer, intent(in) :: im, levs, nvdiff, ntrac + integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc + integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv + logical, intent(in) :: trans_aero, ldiag3d, qdiag3d, lssav + integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 + integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires + logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_hail_on, nssl_ccn_on + + real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs + real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs + real(kind=kind_phys), dimension(:,:, :), intent(inout) :: vdftra + real(kind=kind_phys), dimension(:,:), intent(out) :: save_u, save_v, save_t + real(kind=kind_phys), dimension(:,:, :), intent(out) :: save_q + + ! CCPP error handling variables + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real (kind=kind_phys), parameter :: zero = 0.0_kp, one=1.0_kp + + ! Local variables + integer :: i, k, kk, k1, n + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + rtg_ozone_index=-1 +!DH: dvdftra is only used if nvdiff != ntrac or (nvdiff == ntrac .and. ) + if (nvdiff == ntrac .and. (hybedmf .or. do_shoc .or. satmedmf)) then + vdftra = qgrs + rtg_ozone_index = ntoz + else + if (imp_physics == imp_physics_wsm6) then + ! WSM6 + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 4 + + ! Ferrier-Aligo + elseif (imp_physics == imp_physics_fer_hires) then + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,nqrimef) + vdftra(i,k,6) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 6 + + elseif (imp_physics == imp_physics_thompson) then + ! Thompson + if(ltaerosol) then + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntlnc) + vdftra(i,k,8) = qgrs(i,k,ntinc) + vdftra(i,k,9) = qgrs(i,k,ntrnc) + vdftra(i,k,10) = qgrs(i,k,ntoz) + vdftra(i,k,11) = qgrs(i,k,ntwa) + vdftra(i,k,12) = qgrs(i,k,ntia) + enddo + enddo + rtg_ozone_index = 10 + else + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntinc) + vdftra(i,k,8) = qgrs(i,k,ntrnc) + vdftra(i,k,9) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 9 + endif + ! MG + elseif (imp_physics == imp_physics_mg) then ! MG3/2 + if (ntgl > 0) then ! MG3 + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntlnc) + vdftra(i,k,8) = qgrs(i,k,ntinc) + vdftra(i,k,9) = qgrs(i,k,ntrnc) + vdftra(i,k,10) = qgrs(i,k,ntsnc) + vdftra(i,k,11) = qgrs(i,k,ntgnc) + vdftra(i,k,12) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 12 + else ! MG2 + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntlnc) + vdftra(i,k,7) = qgrs(i,k,ntinc) + vdftra(i,k,8) = qgrs(i,k,ntrnc) + vdftra(i,k,9) = qgrs(i,k,ntsnc) + vdftra(i,k,10) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 10 + endif + elseif (imp_physics == imp_physics_gfdl) then + ! GFDL MP + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 7 + elseif (imp_physics == imp_physics_zhao_carr) then +! Zhao/Carr/Sundqvist + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 3 + elseif (imp_physics == imp_physics_nssl ) then + ! nssl + IF ( nssl_hail_on ) THEN + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,nthl) + vdftra(i,k,8) = qgrs(i,k,ntlnc) + vdftra(i,k,9) = qgrs(i,k,ntinc) + vdftra(i,k,10) = qgrs(i,k,ntrnc) + vdftra(i,k,11) = qgrs(i,k,ntsnc) + vdftra(i,k,12) = qgrs(i,k,ntgnc) + vdftra(i,k,13) = qgrs(i,k,nthnc) + vdftra(i,k,14) = qgrs(i,k,ntgv) + vdftra(i,k,15) = qgrs(i,k,nthv) + vdftra(i,k,16) = qgrs(i,k,ntoz) + IF ( nssl_ccn_on ) THEN + vdftra(i,k,17) = qgrs(i,k,ntccn) + ENDIF + enddo + enddo + + ELSE + ! no hail + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntlnc) + vdftra(i,k,8) = qgrs(i,k,ntinc) + vdftra(i,k,9) = qgrs(i,k,ntrnc) + vdftra(i,k,10) = qgrs(i,k,ntsnc) + vdftra(i,k,11) = qgrs(i,k,ntgnc) + vdftra(i,k,12) = qgrs(i,k,ntgv) + vdftra(i,k,13) = qgrs(i,k,ntoz) + IF ( nssl_ccn_on ) THEN + vdftra(i,k,14) = qgrs(i,k,ntccn) + ENDIF + enddo + enddo + + ENDIF + + + endif +! + if (trans_aero) then + call set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & + imp_physics_thompson, ltaerosol, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & + errmsg, errflg) + if (errflg /= 0) return + ! + k1 = kk + do n=ntchs,ntchm+ntchs-1 + k1 = k1 + 1 + do k=1,levs + do i=1,im + vdftra(i,k,k1) = qgrs(i,k,n) + enddo + enddo + enddo + endif +! + if (ntke>0) then + do k=1,levs + do i=1,im + vdftra(i,k,ntkev) = qgrs(i,k,ntke) + enddo + enddo + endif +! + endif + + if(ldiag3d .and. lssav .and. flag_for_pbl_generic_tend) then + do k=1,levs + do i=1,im + save_t(i,k) = tgrs(i,k) + save_u(i,k) = ugrs(i,k) + save_v(i,k) = vgrs(i,k) + enddo + enddo + if(qdiag3d) then + do k=1,levs + do i=1,im + save_q(i,k,ntqv) = qgrs(i,k,ntqv) + save_q(i,k,ntoz) = qgrs(i,k,ntoz) + enddo + enddo + if(ntke>0) then + do k=1,levs + do i=1,im + save_q(i,k,ntke) = qgrs(i,k,ntke) + enddo + enddo + endif + endif + endif + + end subroutine GFS_PBL_generic_pre_run + + end module GFS_PBL_generic_pre \ No newline at end of file diff --git a/physics/GFS_PBL_generic_pre.meta b/physics/GFS_PBL_generic_pre.meta new file mode 100644 index 000000000..5f765d508 --- /dev/null +++ b/physics/GFS_PBL_generic_pre.meta @@ -0,0 +1,432 @@ +[ccpp-table-properties] + name = GFS_PBL_generic_pre + type = scheme + dependencies = GFS_PBL_generic_common.F90,machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_PBL_generic_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[nvdiff] + standard_name = number_of_vertical_diffusion_tracers + long_name = number of tracers to diffuse vertically + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[rtg_ozone_index] + standard_name = vertically_diffused_tracer_index_of_ozone + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = out +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in +[ntlnc] + standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array + long_name = tracer index for liquid number concentration + units = index + dimensions = () + type = integer + intent = in +[ntinc] + standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array + long_name = tracer index for ice number concentration + units = index + dimensions = () + type = integer + intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgnc] + standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in +[ntwa] + standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array + long_name = tracer index for water friendly aerosol + units = index + dimensions = () + type = integer + intent = in +[ntia] + standard_name = index_of_mass_number_concentration_of_nonhygroscopic_ice_nucleating_aerosols_in_tracer_concentration_array + long_name = tracer index for ice friendly aerosol + units = index + dimensions = () + type = integer + intent = in +[ntgl] + standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in +[ntke] + standard_name = index_of_turbulent_kinetic_energy_in_tracer_concentration_array + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in +[ntkev] + standard_name = index_for_turbulent_kinetic_energy_vertical_diffusion_tracer + long_name = index for turbulent kinetic energy in the vertically diffused tracer array + units = index + dimensions = () + type = integer + intent = in +[nqrimef] + standard_name = index_of_mass_weighted_rime_factor_in_tracer_concentration_array + long_name = tracer index for mass weighted rime factor + units = index + dimensions = () + type = integer + intent = in +[trans_aero] + standard_name = flag_for_aerosol_convective_transport_and_PBL_diffusion + long_name = flag for aerosol convective transport and PBL diffusion + units = flag + dimensions = () + type = logical + intent = in +[ntchs] + standard_name = index_of_first_chemical_tracer_in_tracer_concentration_array + long_name = tracer index for first chemical tracer + units = index + dimensions = () + type = integer + intent = in +[ntchm] + standard_name = number_of_chemical_tracers + long_name = number of chemical tracers + units = count + dimensions = () + type = integer + intent = in +[ntccn] + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_gfdl] + standard_name = identifier_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_thompson] + standard_name = identifier_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_wsm6] + standard_name = identifier_for_wsm6_microphysics_scheme + long_name = choice of WSM6 microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr] + standard_name = identifier_for_zhao_carr_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_mg] + standard_name = identifier_for_morrison_gettelman_microphysics_scheme + long_name = choice of Morrison-Gettelman microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_fer_hires] + standard_name = identifier_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics + units = flag + dimensions = () + type = logical + intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[hybedmf] + standard_name = flag_for_hybrid_edmf_pbl_scheme + long_name = flag for hybrid edmf pbl scheme (moninedmf) + units = flag + dimensions = () + type = logical + intent = in +[do_shoc] + standard_name = flag_for_shoc + long_name = flag for SHOC + units = flag + dimensions = () + type = logical + intent = in +[satmedmf] + standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL + long_name = flag for scale-aware TKE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[vdftra] + standard_name = vertically_diffused_tracer_concentration + long_name = tracer concentration diffused by PBL scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = inout +[save_u] + standard_name = x_wind_save + long_name = x-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[save_v] + standard_name = y_wind_save + long_name = y-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[save_t] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[save_q] + standard_name = tracer_concentration_save + long_name = tracer concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = out +[flag_for_pbl_generic_tend] + standard_name = flag_for_generic_tendency_due_to_planetary_boundary_layer + long_name = true if GFS_PBL_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[lssav] + standard_name = flag_for_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + 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 \ No newline at end of file diff --git a/physics/GFS_SCNV_generic.F90 b/physics/GFS_SCNV_generic_post.F90 similarity index 63% rename from physics/GFS_SCNV_generic.F90 rename to physics/GFS_SCNV_generic_post.F90 index 58447f6bf..adc8fc1c8 100644 --- a/physics/GFS_SCNV_generic.F90 +++ b/physics/GFS_SCNV_generic_post.F90 @@ -1,93 +1,10 @@ -!> \file GFS_SCNV_generic.F90 -!! Contains code related to shallow convective schemes to be used within the GFS physics suite. - - module GFS_SCNV_generic_pre - - contains - - subroutine GFS_SCNV_generic_pre_init () - end subroutine GFS_SCNV_generic_pre_init - - subroutine GFS_SCNV_generic_pre_finalize() - end subroutine GFS_SCNV_generic_pre_finalize - -!> \section arg_table_GFS_SCNV_generic_pre_run Argument Table -!! \htmlinclude GFS_SCNV_generic_pre_run.html -!! - subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, gu0, gv0, gt0, gq0, & - save_u, save_v, save_t, save_q, ntqv, nsamftrac, flag_for_scnv_generic_tend, & - dtidx, index_of_process_scnv, ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & - cscnv, satmedmf, trans_trac, ras, ntrac, clw, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: im, levs, ntqv, nsamftrac, index_of_process_scnv, dtidx(:,:) - integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac - logical, intent(in) :: ldiag3d, qdiag3d, flag_for_scnv_generic_tend - real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 - real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0 - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q - real(kind=kind_phys), dimension(:,:), intent(inout) :: save_u, save_v, save_t - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - logical, intent(in) :: cscnv, satmedmf, trans_trac, ras - real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw - - integer :: i, k, n, tracers - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (ldiag3d .and. flag_for_scnv_generic_tend) then - do k=1,levs - do i=1,im - save_u(i,k) = gu0(i,k) - save_v(i,k) = gv0(i,k) - save_t(i,k) = gt0(i,k) - enddo - enddo - if (qdiag3d) then - if (cscnv .or. satmedmf .or. trans_trac .or. ras) then - tracers = 2 - do n=2,ntrac - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then - tracers = tracers + 1 - if(dtidx(100+n,index_of_process_scnv)>0) then - save_q(:,:,n) = clw(:,:,tracers) - endif - endif - enddo - else - do n=2,ntrac - if(dtidx(100+n,index_of_process_scnv)>0) then - save_q(:,:,n) = gq0(:,:,n) - endif - enddo - endif ! end if_ras or cfscnv or samf - save_q(:,:,ntqv) = gq0(:,:,ntqv) - endif - endif - - end subroutine GFS_SCNV_generic_pre_run - - - end module GFS_SCNV_generic_pre +!> \file GFS_SCNV_generic_post.F90 +!! Contains code related to shallow convective schemes to be used after shallow convection for GFS-based physics suites. module GFS_SCNV_generic_post contains - subroutine GFS_SCNV_generic_post_init () - end subroutine GFS_SCNV_generic_post_init - - subroutine GFS_SCNV_generic_post_finalize () - end subroutine GFS_SCNV_generic_post_finalize - !> \section arg_table_GFS_SCNV_generic_post_run Argument Table !! \htmlinclude GFS_SCNV_generic_post_run.html !! diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic_post.meta similarity index 62% rename from physics/GFS_SCNV_generic.meta rename to physics/GFS_SCNV_generic_post.meta index 5cbda127c..ab9f51562 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic_post.meta @@ -1,261 +1,3 @@ -[ccpp-table-properties] - name = GFS_SCNV_generic_pre - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_SCNV_generic_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = flag for 3d tracer diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[gu0] - standard_name = x_wind_of_new_state - long_name = updated x-direction wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gv0] - standard_name = y_wind_of_new_state - long_name = updated y-direction wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[save_u] - standard_name = x_wind_save - long_name = x-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_v] - standard_name = y_wind_save - long_name = y-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_t] - standard_name = air_temperature_save - long_name = air temperature before entering a physics scheme - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_q] - standard_name = tracer_concentration_save - long_name = tracer concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[ntqv] - standard_name = index_of_specific_humidity_in_tracer_concentration_array - long_name = tracer index for water vapor (specific humidity) - units = index - dimensions = () - type = integer - intent = in -[nsamftrac] - standard_name = number_of_tracers_for_samf - long_name = number of tracers for scale-aware mass flux schemes - units = count - dimensions = () - type = integer - intent = in -[flag_for_scnv_generic_tend] - standard_name = flag_for_generic_tendency_due_to_shallow_convection - long_name = true if GFS_SCNV_generic should calculate tendencies - units = flag - dimensions = () - type = logical - intent = in -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[index_of_process_scnv] - standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index - long_name = index of shallow convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[cscnv] - standard_name = flag_for_Chikira_Sugiyama_deep_convection - long_name = flag for Chikira-Sugiyama convection - units = flag - dimensions = () - type = logical - intent = in -[satmedmf] - standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL - long_name = flag for scale-aware TKE moist EDMF PBL scheme - units = flag - dimensions = () - type = logical - intent = in -[trans_trac] - standard_name = flag_for_convective_transport_of_tracers - long_name = flag for convective transport of tracers - units = flag - dimensions = () - type = logical - intent = in -[ras] - standard_name = flag_for_relaxed_arakawa_schubert_deep_convection - long_name = flag for ras convection scheme - units = flag - dimensions = () - type = logical - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[ntclamt] - standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in -[ntrw] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[ntsw] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[ntrnc] - standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in -[ntsnc] - standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[ntgnc] - standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[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-table-properties] name = GFS_SCNV_generic_post diff --git a/physics/GFS_SCNV_generic_pre.F90 b/physics/GFS_SCNV_generic_pre.F90 new file mode 100644 index 000000000..0740127bd --- /dev/null +++ b/physics/GFS_SCNV_generic_pre.F90 @@ -0,0 +1,73 @@ +!> \file GFS_SCNV_generic_pre.F90 +!! Contains code related to shallow convective schemes to be run prior to shallow convection for GFS-based physics suites. + + module GFS_SCNV_generic_pre + + contains + +!> \section arg_table_GFS_SCNV_generic_pre_run Argument Table +!! \htmlinclude GFS_SCNV_generic_pre_run.html +!! + subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, gu0, gv0, gt0, gq0, & + save_u, save_v, save_t, save_q, ntqv, nsamftrac, flag_for_scnv_generic_tend, & + dtidx, index_of_process_scnv, ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & + cscnv, satmedmf, trans_trac, ras, ntrac, clw, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + integer, intent(in) :: im, levs, ntqv, nsamftrac, index_of_process_scnv, dtidx(:,:) + integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac + logical, intent(in) :: ldiag3d, qdiag3d, flag_for_scnv_generic_tend + real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 + real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0 + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q + real(kind=kind_phys), dimension(:,:), intent(inout) :: save_u, save_v, save_t + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + logical, intent(in) :: cscnv, satmedmf, trans_trac, ras + real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw + + integer :: i, k, n, tracers + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (ldiag3d .and. flag_for_scnv_generic_tend) then + do k=1,levs + do i=1,im + save_u(i,k) = gu0(i,k) + save_v(i,k) = gv0(i,k) + save_t(i,k) = gt0(i,k) + enddo + enddo + if (qdiag3d) then + if (cscnv .or. satmedmf .or. trans_trac .or. ras) then + tracers = 2 + do n=2,ntrac + if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & + n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + tracers = tracers + 1 + if(dtidx(100+n,index_of_process_scnv)>0) then + save_q(:,:,n) = clw(:,:,tracers) + endif + endif + enddo + else + do n=2,ntrac + if(dtidx(100+n,index_of_process_scnv)>0) then + save_q(:,:,n) = gq0(:,:,n) + endif + enddo + endif ! end if_ras or cfscnv or samf + save_q(:,:,ntqv) = gq0(:,:,ntqv) + endif + endif + + end subroutine GFS_SCNV_generic_pre_run + + + end module GFS_SCNV_generic_pre \ No newline at end of file diff --git a/physics/GFS_SCNV_generic_pre.meta b/physics/GFS_SCNV_generic_pre.meta new file mode 100644 index 000000000..07af85a70 --- /dev/null +++ b/physics/GFS_SCNV_generic_pre.meta @@ -0,0 +1,257 @@ +[ccpp-table-properties] + name = GFS_SCNV_generic_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_SCNV_generic_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[gu0] + standard_name = x_wind_of_new_state + long_name = updated x-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gv0] + standard_name = y_wind_of_new_state + long_name = updated y-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[save_u] + standard_name = x_wind_save + long_name = x-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_v] + standard_name = y_wind_save + long_name = y-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_t] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_q] + standard_name = tracer_concentration_save + long_name = tracer concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[nsamftrac] + standard_name = number_of_tracers_for_samf + long_name = number of tracers for scale-aware mass flux schemes + units = count + dimensions = () + type = integer + intent = in +[flag_for_scnv_generic_tend] + standard_name = flag_for_generic_tendency_due_to_shallow_convection + long_name = true if GFS_SCNV_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_process_scnv] + standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index + long_name = index of shallow convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[cscnv] + standard_name = flag_for_Chikira_Sugiyama_deep_convection + long_name = flag for Chikira-Sugiyama convection + units = flag + dimensions = () + type = logical + intent = in +[satmedmf] + standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL + long_name = flag for scale-aware TKE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in +[trans_trac] + standard_name = flag_for_convective_transport_of_tracers + long_name = flag for convective transport of tracers + units = flag + dimensions = () + type = logical + intent = in +[ras] + standard_name = flag_for_relaxed_arakawa_schubert_deep_convection + long_name = flag for ras convection scheme + units = flag + dimensions = () + type = logical + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[ntclamt] + standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgl] + standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in +[ntgnc] + standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[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 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 deleted file mode 100644 index 044912e07..000000000 --- a/physics/GFS_suite_interstitial.F90 +++ /dev/null @@ -1,1043 +0,0 @@ -!> \file GFS_suite_interstitial.f90 -!! Contains code related to more than one scheme in the GFS physics suite. - - module GFS_suite_interstitial_rad_reset - - contains - - subroutine GFS_suite_interstitial_rad_reset_init () - end subroutine GFS_suite_interstitial_rad_reset_init - - subroutine GFS_suite_interstitial_rad_reset_finalize() - end subroutine GFS_suite_interstitial_rad_reset_finalize - -!> \section arg_table_GFS_suite_interstitial_rad_reset_run Argument Table -!! \htmlinclude GFS_suite_interstitial_rad_reset_run.html -!! - subroutine GFS_suite_interstitial_rad_reset_run (Interstitial, Model, errmsg, errflg) - - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type - - implicit none - - ! interface variables - type(GFS_interstitial_type), intent(inout) :: Interstitial - type(GFS_control_type), intent(in) :: Model - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = '' - errflg = 0 - - call Interstitial%rad_reset(Model) - - end subroutine GFS_suite_interstitial_rad_reset_run - - end module GFS_suite_interstitial_rad_reset - - - module GFS_suite_interstitial_phys_reset - - contains - - subroutine GFS_suite_interstitial_phys_reset_init () - end subroutine GFS_suite_interstitial_phys_reset_init - - subroutine GFS_suite_interstitial_phys_reset_finalize() - end subroutine GFS_suite_interstitial_phys_reset_finalize - -!> \section arg_table_GFS_suite_interstitial_phys_reset_run Argument Table -!! \htmlinclude GFS_suite_interstitial_phys_reset_run.html -!! - subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Model, errmsg, errflg) - - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type - - implicit none - - ! interface variables - type(GFS_interstitial_type), intent(inout) :: Interstitial - type(GFS_control_type), intent(in ) :: Model - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - errmsg = '' - errflg = 0 - - call Interstitial%phys_reset(Model) - - end subroutine GFS_suite_interstitial_phys_reset_run - - end module GFS_suite_interstitial_phys_reset - - - module GFS_suite_interstitial_1 - - contains - - subroutine GFS_suite_interstitial_1_init () - end subroutine GFS_suite_interstitial_1_init - - subroutine GFS_suite_interstitial_1_finalize() - end subroutine GFS_suite_interstitial_1_finalize - -!> \section arg_table_GFS_suite_interstitial_1_run Argument Table -!! \htmlinclude GFS_suite_interstitial_1_run.html -!! - subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, dxmin, dxinv, pgr, & - islmsk, work1, work2, psurf, dudt, dvdt, dtdt, dqdt, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - integer, intent(in ) :: im, levs, ntrac - real(kind=kind_phys), intent(in ) :: dtf, dtp, dxmin, dxinv - real(kind=kind_phys), intent(in ), dimension(:) :: slmsk, area, pgr - - integer, intent(out), dimension(:) :: islmsk - real(kind=kind_phys), intent(out), dimension(:) :: work1, work2, psurf - real(kind=kind_phys), intent(out), dimension(:,:) :: dudt, dvdt, dtdt - real(kind=kind_phys), intent(out), dimension(:,:,:) :: dqdt - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - integer :: i, k, n - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i = 1, im - islmsk(i) = nint(slmsk(i)) - - work1(i) = (log(area(i)) - dxmin) * dxinv - work1(i) = max(zero, min(one, work1(i))) - work2(i) = one - work1(i) - psurf(i) = pgr(i) - end do - - do k=1,levs - do i=1,im - dudt(i,k) = zero - dvdt(i,k) = zero - dtdt(i,k) = zero - enddo - enddo - do n=1,ntrac - do k=1,levs - do i=1,im - dqdt(i,k,n) = zero - enddo - enddo - enddo - - end subroutine GFS_suite_interstitial_1_run - - end module GFS_suite_interstitial_1 - - - module GFS_suite_interstitial_2 - - use machine, only: kind_phys - real(kind=kind_phys), parameter :: one = 1.0_kind_phys - logical :: linit_mod = .false. - - contains - - subroutine GFS_suite_interstitial_2_init () - end subroutine GFS_suite_interstitial_2_init - - subroutine GFS_suite_interstitial_2_finalize() - end subroutine GFS_suite_interstitial_2_finalize - -!> \section arg_table_GFS_suite_interstitial_2_run Argument Table -!! \htmlinclude GFS_suite_interstitial_2_run.html -!! - subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, flag_cice, shal_cnv, old_monin, mstrat, & - do_shoc, frac_grid, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, cice, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, & - work1, work2, prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, suntim, adjsfculw, adjsfculw_lnd, & - adjsfculw_ice, adjsfculw_wat, dlwsfc, ulwsfc, psmean, dtend, dtidx, index_of_process_longwave, index_of_process_shortwave, & - index_of_process_pbl, index_of_process_dcnv, index_of_process_scnv, index_of_process_mp, index_of_temperature, & - ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, use_LW_jacobian, htrlwu, errmsg, errflg) - - implicit none - - ! interface variables - integer, intent(in ) :: im, levs, imfshalcnv - logical, intent(in ) :: lssav, ldiag3d, lsidea, shal_cnv - logical, intent(in ) :: old_monin, mstrat, do_shoc, frac_grid, use_LW_jacobian - real(kind=kind_phys), intent(in ) :: dtf, cp, hvap - - logical, intent(in ), dimension(:) :: flag_cice - real(kind=kind_phys), intent(in ), dimension(:) :: ctei_rm - real(kind=kind_phys), intent(in ), dimension(:) :: xcosz, adjsfcdsw, adjsfcdlw, pgr, xmu, work1, work2 - real(kind=kind_phys), intent(in ), dimension(:) :: ulwsfc_cice - real(kind=kind_phys), intent(in ), dimension(:) :: cice - real(kind=kind_phys), intent(in ), dimension(:,:) :: htrsw, htrlw, htrlwu, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, prslk - real(kind=kind_phys), intent(in ), dimension(:,:) :: prsi - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: lwhd - integer, intent(inout), dimension(:) :: kinver - real(kind=kind_phys), intent(inout), dimension(:) :: suntim, dlwsfc, ulwsfc, psmean, ctei_rml, ctei_r - real(kind=kind_phys), intent(in ), dimension(:) :: adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat - real(kind=kind_phys), intent(inout), dimension(:) :: adjsfculw - - ! dtend is only allocated if ldiag3d is .true. - real(kind=kind_phys), optional, intent(inout), dimension(:,:,:) :: dtend - integer, intent(in), dimension(:,:) :: dtidx - integer, intent(in) :: index_of_process_longwave, index_of_process_shortwave, & - index_of_process_pbl, index_of_process_dcnv, index_of_process_scnv, & - index_of_process_mp, index_of_temperature - - logical, intent(in ), dimension(:) :: dry, icy, wet - real(kind=kind_phys), intent(in ), dimension(:) :: frland - real(kind=kind_phys), intent(in ) :: huge - - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! local variables - real(kind=kind_phys), parameter :: czmin = 0.0001_kind_phys ! cos(89.994) - integer :: i, k, idtend - real(kind=kind_phys) :: tem1, tem2, tem, hocp - logical, dimension(im) :: invrsn - real(kind=kind_phys), dimension(im) :: tx1, tx2 - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - real(kind=kind_phys), parameter :: qmin = 1.0e-10_kind_phys, epsln=1.0e-10_kind_phys - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - hocp = hvap/cp - - if (lssav) then ! --- ... accumulate/save output variables - -! --- ... sunshine duration time is defined as the length of time (in mdl output -! interval) that solar radiation falling on a plane perpendicular to the -! direction of the sun >= 120 w/m2 - - do i = 1, im - if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg - tem1 = adjsfcdsw(i) / xcosz(i) - if ( tem1 >= 120.0_kind_phys ) then - suntim(i) = suntim(i) + dtf - endif - endif - enddo - -! --- ... sfc lw fluxes used by atmospheric model are saved for output - if (frac_grid) then - do i=1,im - tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell - if (flag_cice(i)) then - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + ulwsfc_cice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) - else - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + adjsfculw_ice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) - endif - enddo - else - do i=1,im - if (dry(i)) then ! all land - adjsfculw(i) = adjsfculw_lnd(i) - elseif (icy(i)) then ! ice (and water) - tem = one - cice(i) - if (flag_cice(i)) then - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_wat(i)*tem - else - adjsfculw(i) = ulwsfc_cice(i) - endif - else - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_wat(i)*tem - else - adjsfculw(i) = adjsfculw_ice(i) - endif - endif - else ! all water - adjsfculw(i) = adjsfculw_wat(i) - endif - enddo - endif - - do i=1,im - dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf - ulwsfc(i) = ulwsfc(i) + adjsfculw(i)*dtf - psmean(i) = psmean(i) + pgr(i)*dtf ! mean surface pressure - enddo - - if (ldiag3d) then - if (lsidea) then - idtend = dtidx(index_of_temperature,index_of_process_longwave) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,1)*dtf - endif - - idtend = dtidx(index_of_temperature,index_of_process_shortwave) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,2)*dtf - endif - - idtend = dtidx(index_of_temperature,index_of_process_pbl) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,3)*dtf - endif - - idtend = dtidx(index_of_temperature,index_of_process_dcnv) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,4)*dtf - endif - - idtend = dtidx(index_of_temperature,index_of_process_scnv) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,5)*dtf - endif - - idtend = dtidx(index_of_temperature,index_of_process_mp) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,6)*dtf - endif - else - idtend = dtidx(index_of_temperature,index_of_process_longwave) - if(idtend>=1) then - if (use_LW_jacobian) then - dtend(:,:,idtend) = dtend(:,:,idtend) + htrlwu(:,:)*dtf - else - dtend(:,:,idtend) = dtend(:,:,idtend) + htrlw(:,:)*dtf - endif - endif - - idtend = dtidx(index_of_temperature,index_of_process_shortwave) - if(idtend>=1) then - do k=1,levs - do i=1,im - dtend(i,k,idtend) = dtend(i,k,idtend) + htrsw(i,k)*dtf*xmu(i) - enddo - enddo - endif - endif - endif - endif ! end if_lssav_block - - do i=1, im - invrsn(i) = .false. - tx1(i) = zero - tx2(i) = 10.0_kind_phys - ctei_r(i) = 10.0_kind_phys - enddo - - if ((((imfshalcnv == 0 .and. shal_cnv) .or. old_monin) .and. mstrat) & - .or. do_shoc) then - ctei_rml(:) = ctei_rm(1)*work1(:) + ctei_rm(2)*work2(:) - do k=1,levs/2 - do i=1,im - if (prsi(i,1)-prsi(i,k+1) < 0.35_kind_phys*prsi(i,1) & - .and. (.not. invrsn(i))) then - tem = (tgrs(i,k+1) - tgrs(i,k)) & - / (prsl(i,k) - prsl(i,k+1)) - - if (((tem > 0.0001_kind_phys) .and. (tx1(i) < zero)) .or. & - ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) then - invrsn(i) = .true. - - if (qgrs_water_vapor(i,k) > qgrs_water_vapor(i,k+1)) then - tem1 = tgrs(i,k+1) + hocp*max(qgrs_water_vapor(i,k+1),qmin) - tem2 = tgrs(i,k) + hocp*max(qgrs_water_vapor(i,k),qmin) - - tem1 = tem1 / prslk(i,k+1) - tem2 / prslk(i,k) - -! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI - ctei_r(i) = (one/hocp)*tem1/(qgrs_water_vapor(i,k+1)-qgrs_water_vapor(i,k) & - + qgrs_cloud_water(i,k+1)-qgrs_cloud_water(i,k)) - else - ctei_r(i) = 10.0_kind_phys - endif - - if ( ctei_rml(i) > ctei_r(i) ) then - kinver(i) = k - else - kinver(i) = levs - endif - endif - - tx2(i) = tx1(i) - tx1(i) = tem - endif - enddo - enddo - endif - - end subroutine GFS_suite_interstitial_2_run - - end module GFS_suite_interstitial_2 - - - module GFS_suite_stateout_reset - - contains - - subroutine GFS_suite_stateout_reset_init () - end subroutine GFS_suite_stateout_reset_init - - subroutine GFS_suite_stateout_reset_finalize() - end subroutine GFS_suite_stateout_reset_finalize - -!> \section arg_table_GFS_suite_stateout_reset_run Argument Table -!! \htmlinclude GFS_suite_stateout_reset_run.html -!! - subroutine GFS_suite_stateout_reset_run (im, levs, ntrac, & - tgrs, ugrs, vgrs, qgrs, & - gt0 , gu0 , gv0 , gq0 , & - errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - integer, intent(in ) :: im - integer, intent(in ) :: levs - integer, intent(in ) :: ntrac - real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs - real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0 - real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - gt0(:,:) = tgrs(:,:) - gu0(:,:) = ugrs(:,:) - gv0(:,:) = vgrs(:,:) - gq0(:,:,:) = qgrs(:,:,:) - - end subroutine GFS_suite_stateout_reset_run - - end module GFS_suite_stateout_reset - - - module GFS_suite_stateout_update - - contains - - subroutine GFS_suite_stateout_update_init () - end subroutine GFS_suite_stateout_update_init - - subroutine GFS_suite_stateout_update_finalize() - end subroutine GFS_suite_stateout_update_finalize - -!> \section arg_table_GFS_suite_stateout_update_run Argument Table -!! \htmlinclude GFS_suite_stateout_update_run.html -!! - subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & - tgrs, ugrs, vgrs, qgrs, dudt, dvdt, dtdt, dqdt, & - gt0, gu0, gv0, gq0, ntiw, nqrimef, imp_physics, & - imp_physics_fer_hires, epsq, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in ) :: im - integer, intent(in ) :: levs - integer, intent(in ) :: ntrac - integer, intent(in ) :: imp_physics,imp_physics_fer_hires - integer, intent(in ) :: ntiw, nqrimef - real(kind=kind_phys), intent(in ) :: dtp, epsq - - real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs - real(kind=kind_phys), intent(in ), dimension(:,:) :: dudt, dvdt, dtdt - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: dqdt - real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0 - real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp - gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp - gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp - gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp - - if (imp_physics == imp_physics_fer_hires) then - do k=1,levs - do i=1,im - if(gq0(i,k,ntiw) > epsq) then - gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw)) - else - gq0(i,k,nqrimef) = 1. - end if - end do - end do - end if - - end subroutine GFS_suite_stateout_update_run - - end module GFS_suite_stateout_update - - - module GFS_suite_interstitial_3 - - contains - - subroutine GFS_suite_interstitial_3_init () - end subroutine GFS_suite_interstitial_3_init - - subroutine GFS_suite_interstitial_3_finalize() - end subroutine GFS_suite_interstitial_3_finalize - -!> \section arg_table_GFS_suite_interstitial_3_run Argument Table -!! \htmlinclude GFS_suite_interstitial_3_run.html -!! - subroutine GFS_suite_interstitial_3_run (otsptflag, & - im, levs, nn, cscnv, & - satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & - ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & - xlon, xlat, gt0, gq0, imp_physics, imp_physics_mg, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - imp_physics_gfdl, imp_physics_thompson, dtidx, ntlnc, & - imp_physics_wsm6, imp_physics_fer_hires, prsi, ntinc, & - imp_physics_nssl, & - prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & - work1, work2, kpbl, kinver, ras, me, save_lnc, save_inc, & - ldiag3d, qdiag3d, index_of_process_conv_trans, & - clw, rhc, save_qc, save_qi, save_tcp, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport (size ntrac) - integer, intent(in ) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, ntsw,& - ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & - imp_physics_nssl, me, index_of_process_conv_trans - integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver - logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras - - integer, intent(in) :: ntinc, ntlnc - logical, intent(in) :: ldiag3d, qdiag3d - integer, dimension(:,:), intent(in) :: dtidx - real, dimension(:,:), intent(out) :: save_lnc, save_inc - - real(kind=kind_phys), intent(in ) :: rhcbot, rhcmax, rhcpbl, rhctop - real(kind=kind_phys), intent(in ), dimension(:) :: work1, work2 - real(kind=kind_phys), intent(in ), dimension(:,:) :: prsl, prslk - real(kind=kind_phys), intent(in ), dimension(:,:) :: prsi - real(kind=kind_phys), intent(in ), dimension(:) :: xlon, xlat - real(kind=kind_phys), intent(in ), dimension(:,:) :: gt0 - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: gq0 - - real(kind=kind_phys), intent(inout), dimension(:,:) :: rhc, save_qc - ! save_qi is not allocated for Zhao-Carr MP - real(kind=kind_phys), intent(inout), dimension(:,:) :: save_qi - real(kind=kind_phys), intent(inout), dimension(:,:) :: save_tcp - real(kind=kind_phys), intent(inout), dimension(:,:,:) :: clw - - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! local variables - integer :: i,k,n,tracers,kk - real(kind=kind_phys) :: tem, tem1, tem2 - real(kind=kind_phys), dimension(im) :: tx1, tx2, tx3, tx4 - - !real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.04, & - ! turnrhcrit = 0.900, turnrhcrit_upper = 0.150 - ! in the following inverse of slope_mg and slope_upmg are specified - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - real(kind=kind_phys), parameter :: slope_mg = 50.0_kind_phys, & - slope_upmg = 25.0_kind_phys - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (cscnv .or. satmedmf .or. trans_trac .or. ras) then - tracers = 2 - do n=2,ntrac -! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & -! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & -! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then - IF ( otsptflag(n) ) THEN - tracers = tracers + 1 - do k=1,levs - do i=1,im - clw(i,k,tracers) = gq0(i,k,n) - enddo - enddo - endif - enddo - endif ! end if_ras or cfscnv or samf - - if (ntcw > 0) then - if (imp_physics == imp_physics_mg .and. rhcpbl < 0.5_kind_phys) then ! compute rhc for GMAO macro physics cloud pdf - do i=1,im - tx1(i) = one / prsi(i,1) - tx2(i) = one - rhcmax*work1(i)-rhcbot*work2(i) - - kk = min(kinver(i), max(2,kpbl(i))) - tx3(i) = prsi(i,kk)*tx1(i) - tx4(i) = rhcpbl - rhctop*abs(cos(xlat(i))) - enddo - do k = 1, levs - do i = 1, im - tem = prsl(i,k) * tx1(i) - tem1 = min(max((tem-tx3(i))*slope_mg, -20.0_kind_phys), 20.0_kind_phys) - ! Using rhcpbl and rhctop from the namelist instead of 0.3 and 0.2 - ! and rhcbot represents pbl top critical relative humidity - tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0_kind_phys), 20.0_kind_phys) ! Anning - if (islmsk(i) > 0) then - tem1 = one / (one+exp(tem1+tem1)) - else - tem1 = 2.0_kind_phys / (one+exp(tem1+tem1)) - endif - tem2 = one / (one+exp(tem2)) - - rhc(i,k) = min(rhcmax, max(0.7_kind_phys, one-tx2(i)*tem1*tem2)) - enddo - enddo - else - do k=1,levs - do i=1,im - kk = max(10,kpbl(i)) - if (k < kk) then - tem = rhcbot - (rhcbot-rhcpbl) * (one-prslk(i,k)) / (one-prslk(i,kk)) - else - tem = rhcpbl - (rhcpbl-rhctop) * (prslk(i,kk)-prslk(i,k)) / prslk(i,kk) - endif - tem = rhcmax * work1(i) + tem * work2(i) - rhc(i,k) = max(zero, min(one,tem)) - enddo - enddo - endif - else - rhc(:,:) = 1.0 - endif - - if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_zhao_carr_pdf) then ! zhao-carr microphysics - !GF* move to GFS_MP_generic_pre (from gscond/precpd) - ! do i=1,im - ! psautco_l(i) = Model%psautco(1)*work1(i) + Model%psautco(2)*work2(i) - ! prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) - ! enddo - !*GF - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntcw) - enddo - enddo - elseif (imp_physics == imp_physics_gfdl) then - clw(1:im,:,1) = gq0(1:im,:,ntcw) - elseif (imp_physics == imp_physics_thompson) then - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! ice - clw(i,k,2) = gq0(i,k,ntcw) ! water - save_tcp(i,k) = gt0(i,k) - enddo - enddo - if(ltaerosol) then - save_qi(:,:) = clw(:,:,1) - save_qc(:,:) = clw(:,:,2) - else - save_qi(:,:) = clw(:,:,1) - endif - else if (imp_physics == imp_physics_nssl ) then - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! cloud ice - clw(i,k,2) = gq0(i,k,ntcw) ! cloud droplets - enddo - enddo - save_qi(:,:) = clw(:,:,1) - save_qc(:,:) = clw(:,:,2) - elseif (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_mg .or. imp_physics == imp_physics_fer_hires) then - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! ice - clw(i,k,2) = gq0(i,k,ntcw) ! water - enddo - enddo - endif - - if(imp_physics == imp_physics_thompson .and. ldiag3d .and. qdiag3d) then - if(dtidx(100+ntlnc,index_of_process_conv_trans)>0) then - save_lnc = gq0(:,:,ntlnc) - endif - if(dtidx(100+ntinc,index_of_process_conv_trans)>0) then - save_inc = gq0(:,:,ntinc) - endif - endif - - end subroutine GFS_suite_interstitial_3_run - - end module GFS_suite_interstitial_3 - - module GFS_suite_interstitial_4 - - contains - - subroutine GFS_suite_interstitial_4_init () - end subroutine GFS_suite_interstitial_4_init - - subroutine GFS_suite_interstitial_4_finalize() - end subroutine GFS_suite_interstitial_4_finalize - -!> \section arg_table_GFS_suite_interstitial_4_run Argument Table -!! \htmlinclude GFS_suite_interstitial_4_run.html -!! - subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & - ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_nssl, nssl_invertccn, nssl_ccn_on, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& - index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nssl_cccn, nwfa, spechum, ldiag3d, & - qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, errmsg, errflg) - - use machine, only: kind_phys - use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber - - implicit none - - ! interface variables - - logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport by updraft and - integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & - ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl - - logical, intent(in) :: ltaerosol, convert_dry_rho - logical, intent(in) :: nssl_ccn_on, nssl_invertccn - - real(kind=kind_phys), intent(in ) :: con_pi, dtf - real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc - ! save_qi is not allocated for Zhao-Carr MP - real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qi, save_lnc, save_inc - - ! dtend and dtidx are only allocated if ldiag3d - logical, intent(in) :: ldiag3d, qdiag3d - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: dtend - integer, dimension(:,:), intent(in) :: dtidx - integer, intent(in) :: index_of_process_conv_trans,ntk,ntke - - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: gq0 - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: clw - real(kind=kind_phys), dimension(:,:), intent(in) :: prsl - real(kind=kind_phys), intent(in) :: con_rd, con_eps, nssl_cccn - real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp - real(kind=kind_phys), dimension(:,:), intent(in) :: spechum - - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! local variables - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - integer :: i,k,n,tracers,idtend - real(kind=kind_phys) :: liqm, icem, xccn, xcwmas, xccw, xcimas, qccn - - real(kind=kind_phys) :: rho, orho - real(kind=kind_phys), dimension(im,levs) :: qv_mp !< kg kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: qc_mp !< kg kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: qi_mp !< kg kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: nc_mp !< kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: ni_mp !< kg-1 (dry mixing ratio) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! This code was previously in GFS_SCNV_generic_post, but it really belongs - ! here, because it fixes the convective transportable_tracers mess for Zhao-Carr - ! and GFDL MP from GFS_suite_interstitial_3. This whole code around clw(:,:,2) - ! being set to -999 for Zhao-Carr MP (which doesn't have cloud ice) and GFDL-MP - ! (which does have cloud ice, but for some reason it was decided to code it up - ! in the same way as for Zhao-Carr, nowadays unnecessary and confusing) needs - ! to be cleaned up. The convection schemes doing something different internally - ! based on clw(i,k,2) being -999.0 or not is not a good idea. - do k=1,levs - do i=1,im - if (clw(i,k,2) <= -999.0) clw(i,k,2) = 0.0 - enddo - enddo - - if(ldiag3d) then - if(ntk>0 .and. ntk<=size(clw,3)) then - idtend=dtidx(100+ntke,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,ntk)-gq0(:,:,ntk) - endif - endif - if(ntcw>0) then - if (imp_physics == imp_physics_zhao_carr .or. & - imp_physics == imp_physics_zhao_carr_pdf .or. & - imp_physics == imp_physics_gfdl) then - idtend=dtidx(100+ntcw,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)+clw(:,:,2) - gq0(:,:,ntcw) - endif - else if(ntiw>0) then - idtend=dtidx(100+ntiw,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)-gq0(:,:,ntiw) - endif - idtend=dtidx(100+ntcw,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,2)-gq0(:,:,ntcw) - endif - else - idtend=dtidx(100+ntcw,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)+clw(:,:,2) - gq0(:,:,ntcw) - endif - endif - endif - endif - -! --- update the tracers due to deep & shallow cumulus convective transport -! (except for suspended water and ice) - - if (tracers_total > 0) then - tracers = 2 - do n=2,ntrac -! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then -! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & -! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & -! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc & -! .and. & -! n /= nthl .and. n /= nthnc .and. n /= ntgv .and. & -! n /= nthv .and. n /= ntccn & -! ) then - IF ( otsptflag(n) ) THEN - tracers = tracers + 1 - if(n/=ntk .and. n/=ntlnc .and. n/=ntinc .and. n /= ntcw .and. n /= ntiw) then - idtend=dtidx(100+n,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,tracers)-gq0(:,:,n) - endif - endif - do k=1,levs - do i=1,im - gq0(i,k,n) = clw(i,k,tracers) - enddo - enddo - endif - enddo - endif - - if (ntcw > 0) then - -! for microphysics - if (imp_physics == imp_physics_zhao_carr .or. & - imp_physics == imp_physics_zhao_carr_pdf .or. & - imp_physics == imp_physics_gfdl) then - gq0(1:im,:,ntcw) = clw(1:im,:,1) + clw(1:im,:,2) - - elseif (ntiw > 0) then - do k=1,levs - do i=1,im - gq0(i,k,ntiw) = clw(i,k,1) ! ice - gq0(i,k,ntcw) = clw(i,k,2) ! water - enddo - enddo - - if ( imp_physics == imp_physics_nssl ) then - liqm = con_pi/6.*1.e3*(18.e-6)**3 ! 4./3.*con_pi*1.e-12 - icem = con_pi/6.*1.e3*(120.e-6)**3 ! 4./3.*con_pi*3.2768*1.e-14*890. - qccn = nssl_cccn/1.225 !1.225 is a reference air density and should match what is used in module_mp_nssl_2mom.F90 (rho00) - do k=1,levs - do i=1,im - ! check number of available ccn - IF ( nssl_ccn_on ) THEN - IF ( nssl_invertccn ) THEN - xccn = qccn - gq0(i,k,ntccn) - ELSE - xccn = gq0(i,k,ntccn) - ENDIF - ELSE - xccn = Max(0.0, qccn - gq0(i,k,ntlnc)) - ENDIF - - IF ( gq0(i,k,ntlnc) > 0.0 .and. save_qc(i,k) > 0.0 ) THEN - xcwmas = Max( liqm, clw(i,k,2)/gq0(i,k,ntlnc) ) - ELSE - xcwmas = liqm - ENDIF - - IF ( gq0(i,k,ntinc) > 0.0 .and. save_qi(i,k) > 0.0 ) THEN - xcimas = Max( liqm, clw(i,k,1)/gq0(i,k,ntinc) ) - ELSE - xcimas = icem - ENDIF - - IF ( xccn > 0.0 ) THEN - xccw = Min( xccn, max(0.0, (clw(i,k,2)-save_qc(i,k))) / xcwmas ) - gq0(i,k,ntlnc) = gq0(i,k,ntlnc) + xccw - IF ( nssl_ccn_on ) THEN - IF ( nssl_invertccn ) THEN - ! ccn are activated CCN, so add - gq0(i,k,ntccn) = gq0(i,k,ntccn) + xccw - ELSE - ! ccn are unactivated CCN, so subtract - gq0(i,k,ntccn) = gq0(i,k,ntccn) - xccw - ENDIF - ENDIF - ENDIF - - gq0(i,k,ntinc) = gq0(i,k,ntinc) & - + max(0.0, (clw(i,k,1)-save_qi(i,k))) / xcimas - enddo - enddo - endif - - if (imp_physics == imp_physics_thompson .and. (ntlnc>0 .or. ntinc>0)) then - if_convert_dry_rho: if (convert_dry_rho) then - do k=1,levs - do i=1,im - !> - Convert specific humidity to dry mixing ratio - qv_mp(i,k) = spechum(i,k) / (one-spechum(i,k)) - !> - Density of air in kg m-3 and inverse density - rho = con_eps*prsl(i,k) / (con_rd*save_tcp(i,k)*(qv_mp(i,k)+con_eps)) - orho = one/rho - if (ntlnc>0) then - !> - Convert moist mixing ratio to dry mixing ratio - qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) / (one-spechum(i,k)) - !> - Convert number concentration from moist to dry - nc_mp(i,k) = gq0(i,k,ntlnc) / (one-spechum(i,k)) - nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) - !> - Convert number concentrations from dry to moist - gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) - endif - if (ntinc>0) then - !> - Convert moist mixing ratio to dry mixing ratio - qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) / (one-spechum(i,k)) - !> - Convert number concentration from moist to dry - ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) - ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) - !> - Convert number concentrations from dry to moist - gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) - endif - enddo - enddo - else - do k=1,levs - do i=1,im - !> - Density of air in kg m-3 and inverse density - rho = con_eps*prsl(i,k) / (con_rd*save_tcp(i,k)*(spechum(i,k)+con_eps)) - orho = one/rho - if (ntlnc>0) then - !> - Update cloud water mixing ratio - qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) - !> - Update cloud water number concentration - gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) - endif - if (ntinc>0) then - !> - Update cloud ice mixing ratio - qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) - !> - Update cloud ice number concentration - gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) - endif - enddo - enddo - end if if_convert_dry_rho - if(ldiag3d .and. qdiag3d) then - idtend = dtidx(100+ntlnc,index_of_process_conv_trans) - if(idtend>0) then - dtend(:,:,idtend) = dtend(:,:,idtend) + gq0(:,:,ntlnc) - save_lnc - endif - idtend = dtidx(100+ntinc,index_of_process_conv_trans) - if(idtend>0) then - dtend(:,:,idtend) = dtend(:,:,idtend) + gq0(:,:,ntinc) - save_inc - endif - endif - endif - - else - do k=1,levs - do i=1,im - gq0(i,k,ntcw) = clw(i,k,1) + clw(i,k,2) - enddo - enddo - endif ! end if_ntiw - - else - do k=1,levs - do i=1,im - clw(i,k,1) = clw(i,k,1) + clw(i,k,2) - enddo - enddo - endif ! end if_ntcw - - end subroutine GFS_suite_interstitial_4_run - - end module GFS_suite_interstitial_4 - - module GFS_suite_interstitial_5 - - contains - - subroutine GFS_suite_interstitial_5_init () - end subroutine GFS_suite_interstitial_5_init - - subroutine GFS_suite_interstitial_5_finalize() - end subroutine GFS_suite_interstitial_5_finalize - -!> \section arg_table_GFS_suite_interstitial_5_run Argument Table -!! \htmlinclude GFS_suite_interstitial_5_run.html -!! - subroutine GFS_suite_interstitial_5_run (im, levs, ntrac, ntcw, ntiw, nn, gq0, clw, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - integer, intent(in ) :: im, levs, ntrac, ntcw, ntiw, nn - - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: gq0 - - real(kind=kind_phys), intent(out), dimension(:,:,:) :: clw - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - integer :: i,k - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! ice - clw(i,k,2) = gq0(i,k,ntcw) ! water - enddo - enddo - - end subroutine GFS_suite_interstitial_5_run - - end module GFS_suite_interstitial_5 diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta deleted file mode 100644 index 1c0bbed47..000000000 --- a/physics/GFS_suite_interstitial.meta +++ /dev/null @@ -1,1966 +0,0 @@ -[ccpp-table-properties] - name = GFS_suite_interstitial_rad_reset - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_rad_reset_run - type = scheme -[Interstitial] - standard_name = GFS_interstitial_type_instance - long_name = derived type GFS_interstitial_type in FV3 - units = DDT - dimensions = () - type = GFS_interstitial_type - intent = inout -[Model] - standard_name = GFS_control_type_instance - long_name = Fortran DDT containing FV3-GFS model control parameters - units = DDT - dimensions = () - type = GFS_control_type - 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-table-properties] - name = GFS_suite_interstitial_phys_reset - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_phys_reset_run - type = scheme -[Interstitial] - standard_name = GFS_interstitial_type_instance - long_name = derived type GFS_interstitial_type in FV3 - units = DDT - dimensions = () - type = GFS_interstitial_type - intent = inout -[Model] - standard_name = GFS_control_type_instance - long_name = Fortran DDT containing FV3-GFS model control parameters - units = DDT - dimensions = () - type = GFS_control_type - 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-table-properties] - name = GFS_suite_interstitial_1 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_1_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[dtf] - standard_name = timestep_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[slmsk] - standard_name = area_type - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[area] - standard_name = cell_area - long_name = area of the grid cell - units = m2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dxmin] - standard_name = min_grid_scale - long_name = minimum scaling factor for critical relative humidity - units = m2 rad-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[dxinv] - standard_name = reciprocal_of_grid_scale_range - long_name = inverse scaling factor for critical relative humidity - units = rad2 m-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[pgr] - standard_name = surface_air_pressure - long_name = surface pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[islmsk] - standard_name = sea_land_ice_mask - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[psurf] - standard_name = surface_air_pressure_diag - long_name = surface air pressure diagnostic - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[dudt] - standard_name = process_split_cumulative_tendency_of_x_wind - long_name = updated tendency of the x wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[dvdt] - standard_name = process_split_cumulative_tendency_of_y_wind - long_name = updated tendency of the y wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[dtdt] - standard_name = process_split_cumulative_tendency_of_air_temperature - long_name = updated tendency of the temperature - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[dqdt] - standard_name = process_split_cumulative_tendency_of_tracers - long_name = updated tendency of the tracers - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = out -[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-table-properties] - name = GFS_suite_interstitial_2 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_2_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[lssav] - standard_name = flag_for_diagnostics - long_name = logical flag for storing diagnostics - units = flag - dimensions = () - type = logical - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[lsidea] - standard_name = flag_for_integrated_dynamics_through_earths_atmosphere - long_name = flag for idealized physics - units = flag - dimensions = () - type = logical - intent = in -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[shal_cnv] - standard_name = flag_for_simplified_arakawa_schubert_shallow_convection - long_name = flag for calling shallow convection - units = flag - dimensions = () - type = logical - intent = in -[old_monin] - standard_name = flag_for_old_PBL_scheme - long_name = flag for using old PBL schemes - units = flag - dimensions = () - type = logical - intent = in -[mstrat] - standard_name = flag_for_moorthi_stratus - long_name = flag for moorthi approach for stratus - units = flag - dimensions = () - type = logical - intent = in -[do_shoc] - standard_name = flag_for_shoc - long_name = flag for SHOC - units = flag - dimensions = () - type = logical - intent = in -[frac_grid] - standard_name = flag_for_fractional_landmask - long_name = flag for fractional grid - units = flag - dimensions = () - type = logical - intent = in -[imfshalcnv] - standard_name = control_for_shallow_convection_scheme - long_name = flag for mass-flux shallow convection scheme - units = flag - dimensions = () - type = integer - intent = in -[dtf] - standard_name = timestep_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[xcosz] - standard_name = instantaneous_cosine_of_zenith_angle - long_name = cosine of zenith angle at current time - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfcdsw] - standard_name = surface_downwelling_shortwave_flux - long_name = surface downwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfcdlw] - standard_name = surface_downwelling_longwave_flux - long_name = surface downwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[cice] - standard_name = sea_ice_area_fraction_of_sea_area_fraction - long_name = ice fraction over open water - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[pgr] - standard_name = surface_air_pressure - long_name = surface pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[ulwsfc_cice] - standard_name = surface_upwelling_longwave_flux_from_coupled_process - long_name = surface upwelling longwave flux for coupling - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lwhd] - standard_name = tendency_of_air_temperature_due_to_integrated_dynamics_through_earths_atmosphere - long_name = idea sky lw heating rates - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,6) - type = real - kind = kind_phys - intent = in -[htrsw] - standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep - long_name = total sky sw heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[htrlw] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep - long_name = total sky lw heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[xmu] - standard_name = zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes - long_name = zenith angle temporal adjustment factor for shortwave fluxes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[ctei_rm] - standard_name = tunable_parameter_for_critical_cloud_top_entrainment_instability_criteria - long_name = critical cloud top entrainment instability criteria - units = none - dimensions = (2) - type = real - kind = kind_phys - intent = in -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[prsi] - standard_name = air_pressure_at_interface - long_name = air pressure at model layer interfaces - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qgrs_water_vapor] - standard_name = specific_humidity - long_name = water vapor specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qgrs_cloud_water] - standard_name = cloud_liquid_water_mixing_ratio - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[hvap] - standard_name = latent_heat_of_vaporization_of_water_at_0C - long_name = latent heat of evaporation/sublimation - units = J kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[prslk] - standard_name = dimensionless_exner_function - long_name = dimensionless Exner function at model layer centers - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[suntim] - standard_name = duration_of_sunshine - long_name = sunshine duration time - units = s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[use_LW_jacobian] - standard_name = flag_to_calc_RRTMGP_LW_jacobian - long_name = logical flag to control RRTMGP LW calculation - units = flag - dimensions = () - type = logical - intent = in -[htrlwu] - standard_name = updated_tendency_of_air_temperature_due_to_longwave_heating_on_physics_timestep - long_name = total sky longwave heating rate on physics time step - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[adjsfculw] - standard_name = surface_upwelling_longwave_flux - long_name = surface upwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[adjsfculw_lnd] - standard_name = surface_upwelling_longwave_flux_over_land - long_name = surface upwelling longwave flux at current time over land - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfculw_ice] - standard_name = surface_upwelling_longwave_flux_over_ice - long_name = surface upwelling longwave flux at current time over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfculw_wat] - standard_name = surface_upwelling_longwave_flux_over_water - long_name = surface upwelling longwave flux at current time over water - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dlwsfc] - standard_name = cumulative_surface_downwelling_longwave_flux_multiplied_by_timestep - long_name = cumulative surface downwelling LW flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[ulwsfc] - standard_name = cumulative_surface_upwelling_longwave_flux_multiplied_by_timestep - long_name = cumulative surface upwelling LW flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[psmean] - standard_name = cumulative_surface_pressure_multiplied_by_timestep - long_name = cumulative surface pressure multiplied by timestep - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[index_of_process_longwave] - standard_name = index_of_longwave_heating_process_in_cumulative_change_index - long_name = index of longwave heating process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_shortwave] - standard_name = index_of_shortwave_heating_process_in_cumulative_change_index - long_name = index of shortwave heating process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_pbl] - standard_name = index_of_subgrid_scale_vertical_mixing_process_in_cumulative_change_index - long_name = index of subgrid scale vertical mixing process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_dcnv] - standard_name = index_of_deep_convection_process_process_in_cumulative_change_index - long_name = index of deep convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_scnv] - standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index - long_name = index of shallow convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_mp] - standard_name = index_of_microphysics_process_process_in_cumulative_change_index - long_name = index of microphysics transport process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_temperature] - standard_name = index_of_temperature_in_cumulative_change_index - long_name = index of temperature in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[ctei_rml] - standard_name = grid_sensitive_critical_cloud_top_entrainment_instability_criteria - long_name = grid sensitive critical cloud top entrainment instability criteria - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[ctei_r] - standard_name = cloud_top_entrainment_instability_value - long_name = cloud top entrainment instability value - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[kinver] - standard_name = index_of_highest_temperature_inversion - long_name = index of highest temperature inversion - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[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 -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[frland] - standard_name = land_area_fraction_for_microphysics - long_name = land area fraction used in microphysics schemes - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[huge] - standard_name = netcdf_float_fillvalue - long_name = definition of NetCDF float FillValue - units = none - dimensions = () - type = real - kind = kind_phys - 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-table-properties] - name = GFS_suite_stateout_reset - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_stateout_reset_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ugrs] - standard_name = x_wind - long_name = zonal wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vgrs] - standard_name = y_wind - long_name = meridional wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qgrs] - standard_name = tracer_concentration - long_name = model layer mean tracer concentration - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gu0] - standard_name = x_wind_of_new_state - long_name = zonal wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gv0] - standard_name = y_wind_of_new_state - long_name = meridional wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[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 = out -[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-table-properties] - name = GFS_suite_stateout_update - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_stateout_update_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ugrs] - standard_name = x_wind - long_name = zonal wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vgrs] - standard_name = y_wind - long_name = meridional wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qgrs] - standard_name = tracer_concentration - long_name = model layer mean tracer concentration - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[dudt] - standard_name = process_split_cumulative_tendency_of_x_wind - long_name = updated tendency of the x wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dvdt] - standard_name = process_split_cumulative_tendency_of_y_wind - long_name = updated tendency of the y wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dtdt] - standard_name = process_split_cumulative_tendency_of_air_temperature - long_name = updated tendency of the temperature - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dqdt] - standard_name = process_split_cumulative_tendency_of_tracers - long_name = updated tendency of the tracers - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gu0] - standard_name = x_wind_of_new_state - long_name = zonal wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gv0] - standard_name = y_wind_of_new_state - long_name = meridional wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[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 = out -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[nqrimef] - standard_name = index_of_mass_weighted_rime_factor_in_tracer_concentration_array - long_name = tracer index for mass weighted rime factor - units = index - dimensions = () - type = integer - intent = in -[imp_physics] - standard_name = control_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_fer_hires] - standard_name = identifier_for_fer_hires_microphysics_scheme - long_name = choice of Ferrier-Aligo microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[epsq] - standard_name = minimum_value_of_specific_humidity - long_name = floor value for specific humidity - units = kg kg-1 - dimensions = () - type = real - kind = kind_phys - 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-table-properties] - name = GFS_suite_interstitial_3 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_3_run - type = scheme -[otsptflag] - standard_name = flag_convective_tracer_transport_interstitial - long_name = flag for interstitial tracer transport - units = flag - dimensions = (number_of_tracers) - type = logical - intent = in -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[nn] - standard_name = number_of_tracers_for_convective_transport - long_name = number of tracers for convective transport - units = count - dimensions = () - type = integer - intent = in -[cscnv] - standard_name = flag_for_Chikira_Sugiyama_deep_convection - long_name = flag for Chikira-Sugiyama convection - units = flag - dimensions = () - type = logical - intent = in -[satmedmf] - standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL - long_name = flag for scale-aware TKE moist EDMF PBL scheme - units = flag - dimensions = () - type = logical - intent = in -[trans_trac] - standard_name = flag_for_convective_transport_of_tracers - long_name = flag for convective transport of tracers - units = flag - dimensions = () - type = logical - intent = in -[do_shoc] - standard_name = flag_for_shoc - long_name = flag for SHOC - units = flag - dimensions = () - type = logical - intent = in -[ltaerosol] - standard_name = flag_for_aerosol_physics - long_name = flag for aerosol physics - units = flag - dimensions = () - type = logical - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[ntclamt] - standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in -[ntrw] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[ntsw] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[ntrnc] - standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in -[ntsnc] - standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[ntgnc] - standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in -[xlon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xlat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[imp_physics] - standard_name = control_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_mg] - standard_name = identifier_for_morrison_gettelman_microphysics_scheme - long_name = choice of Morrison-Gettelman microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_zhao_carr] - standard_name = identifier_for_zhao_carr_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_zhao_carr_pdf] - standard_name = identifier_for_zhao_carr_pdf_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme with PDF clouds - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_gfdl] - standard_name = identifier_for_gfdl_microphysics_scheme - long_name = choice of GFDL microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_thompson] - standard_name = identifier_for_thompson_microphysics_scheme - long_name = choice of Thompson microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_wsm6] - standard_name = identifier_for_wsm6_microphysics_scheme - long_name = choice of WSM6 microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_fer_hires] - standard_name = identifier_for_fer_hires_microphysics_scheme - long_name = choice of Ferrier-Aligo microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_nssl] - standard_name = identifier_for_nssl_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[prsi] - standard_name = air_pressure_at_interface - long_name = air pressure at model layer interfaces - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[prslk] - standard_name = dimensionless_exner_function - long_name = dimensionless Exner function at model layer centers - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[rhcbot] - standard_name = critical_relative_humidity_at_surface - long_name = critical relative humidity at the surface - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[rhcpbl] - standard_name = critical_relative_humidity_at_PBL_top - long_name = critical relative humidity at the PBL top - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[rhctop] - standard_name = critical_relative_humidity_at_toa - long_name = critical relative humidity at the top of atmosphere - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[rhcmax] - standard_name = max_critical_relative_humidity - long_name = maximum critical relative humidity - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[islmsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[kpbl] - standard_name = vertical_index_at_top_of_atmosphere_boundary_layer - long_name = vertical index at top atmospheric boundary layer - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[kinver] - standard_name = index_of_highest_temperature_inversion - long_name = index of highest temperature inversion - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[ras] - standard_name = flag_for_relaxed_arakawa_schubert_deep_convection - long_name = flag for ras convection scheme - units = flag - dimensions = () - type = logical - intent = in -[me] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = inout -[rhc] - standard_name = critical_relative_humidity - long_name = critical relative humidity - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_qc] - standard_name = cloud_condensed_water_mixing_ratio_save - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_qi] - standard_name = ice_water_mixing_ratio_save - long_name = cloud ice water mixing ratio before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_tcp] - standard_name = air_temperature_save_from_convective_parameterization - long_name = air temperature after cumulus parameterization - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = flag for 3d tracer diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[index_of_process_conv_trans] - standard_name = index_of_convective_transport_process_in_cumulative_change_index - long_name = index of convective transport process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[save_lnc] - standard_name = liquid_cloud_number_concentration_save - long_name = liquid cloud number concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_inc] - standard_name = ice_cloud_number_concentration_save - long_name = ice cloud number concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[ntlnc] - standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array - long_name = tracer index for liquid number concentration - units = index - dimensions = () - type = integer - intent = in -[ntinc] - standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array - long_name = tracer index for ice number concentration - units = index - dimensions = () - type = integer - intent = in -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[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-table-properties] - name = GFS_suite_interstitial_4 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_4_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ltaerosol] - standard_name = flag_for_aerosol_physics - long_name = flag for aerosol physics - units = flag - dimensions = () - type = logical - intent = in -[tracers_total] - standard_name = number_of_total_tracers - long_name = total number of tracers - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[ntclamt] - standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in -[ntrw] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[ntsw] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[ntrnc] - standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in -[ntsnc] - standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[ntgnc] - standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in -[ntlnc] - standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array - long_name = tracer index for liquid number concentration - units = index - dimensions = () - type = integer - intent = in -[ntinc] - standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array - long_name = tracer index for ice number concentration - units = index - dimensions = () - type = integer - intent = in -[nn] - standard_name = number_of_tracers_for_convective_transport - long_name = number of tracers for convective transport - units = count - dimensions = () - type = integer - intent = in -[ntccn] - standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array - long_name = tracer index for cloud condensation nuclei number concentration - units = index - dimensions = () - type = integer - intent = in -[imp_physics] - standard_name = control_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_gfdl] - standard_name = identifier_for_gfdl_microphysics_scheme - long_name = choice of GFDL microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_thompson] - standard_name = identifier_for_thompson_microphysics_scheme - long_name = choice of Thompson microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_zhao_carr] - standard_name = identifier_for_zhao_carr_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_zhao_carr_pdf] - standard_name = identifier_for_zhao_carr_pdf_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme with PDF clouds - units = flag - dimensions = () - type = integer - intent = in -[convert_dry_rho] - standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air - long_name = flag for converting hydrometeors from moist to dry air - units = flag - dimensions = () - type = logical - intent = in -[imp_physics_nssl] - standard_name = identifier_for_nssl_microphysics_scheme - long_name = choice of NSSL 2-moment microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[nssl_ccn_on] - standard_name = nssl_ccn_on - long_name = CCN activation flag in NSSL micro - units = flag - dimensions = () - type = logical - intent = in -[nssl_invertccn] - standard_name = nssl_invertccn - long_name = flag to invert CCN in NSSL micro - units = flag - dimensions = () - type = logical - intent = in -[dtf] - standard_name = timestep_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[save_qc] - standard_name = cloud_condensed_water_mixing_ratio_save - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[save_qi] - standard_name = ice_water_mixing_ratio_save - long_name = cloud ice water mixing ratio before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[save_lnc] - standard_name = liquid_cloud_number_concentration_save - long_name = liquid cloud number concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[save_inc] - standard_name = ice_cloud_number_concentration_save - long_name = ice cloud number concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[con_pi] - standard_name = pi - long_name = ratio of a circle's circumference to its diameter - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[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 -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = inout -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[save_tcp] - standard_name = air_temperature_save_from_convective_parameterization - long_name = air temperature after cumulus parameterization - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[con_rd] - standard_name = gas_constant_of_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_eps] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants - long_name = rd/rv - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[nssl_cccn] - standard_name = nssl_ccn_concentration - long_name = CCN concentration - units = m-3 - dimensions = () - type = real - kind = kind_phys - intent = in -[nwfa] - standard_name = mass_number_concentration_of_hygroscopic_aerosols - long_name = number concentration of water-friendly aerosols - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[spechum] - standard_name = specific_humidity - long_name = water vapor specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - intent = inout -[ntk] - standard_name = index_for_turbulent_kinetic_energy_convective_transport_tracer - long_name = index for turbulent kinetic energy in the convectively transported tracer array - units = index - dimensions = () - type = integer - intent = in -[ntke] - standard_name = index_of_turbulent_kinetic_energy_in_tracer_concentration_array - long_name = tracer index for turbulent kinetic energy - units = index - dimensions = () - type = integer - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = flag for 3d tracer diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[index_of_process_conv_trans] - standard_name = index_of_convective_transport_process_in_cumulative_change_index - long_name = index of convective transport process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[otsptflag] - standard_name = flag_convective_tracer_transport_interstitial - long_name = flag for interstitial tracer transport - units = flag - dimensions = (number_of_tracers) - 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-table-properties] - name = GFS_suite_interstitial_5 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_5_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[nn] - standard_name = number_of_tracers_for_convective_transport - long_name = number of tracers for convective transport - units = count - dimensions = () - type = integer - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) - 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/GFS_suite_interstitial_1.F90 b/physics/GFS_suite_interstitial_1.F90 new file mode 100644 index 000000000..a662d627c --- /dev/null +++ b/physics/GFS_suite_interstitial_1.F90 @@ -0,0 +1,66 @@ +!> \file GFS_suite_interstitial_1.f90 +!! Contains code to calculate scale-aware variables used in cs_conv, gwdc, and precpd and to reset tendencies used in the +!! process-split section of GFS-based physics suites. + + module GFS_suite_interstitial_1 + + contains + +!> \section arg_table_GFS_suite_interstitial_1_run Argument Table +!! \htmlinclude GFS_suite_interstitial_1_run.html +!! + subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, dxmin, dxinv, pgr, & + islmsk, work1, work2, psurf, dudt, dvdt, dtdt, dqdt, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + integer, intent(in ) :: im, levs, ntrac + real(kind=kind_phys), intent(in ) :: dtf, dtp, dxmin, dxinv + real(kind=kind_phys), intent(in ), dimension(:) :: slmsk, area, pgr + + integer, intent(out), dimension(:) :: islmsk + real(kind=kind_phys), intent(out), dimension(:) :: work1, work2, psurf + real(kind=kind_phys), intent(out), dimension(:,:) :: dudt, dvdt, dtdt + real(kind=kind_phys), intent(out), dimension(:,:,:) :: dqdt + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + integer :: i, k, n + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i = 1, im + islmsk(i) = nint(slmsk(i)) + + work1(i) = (log(area(i)) - dxmin) * dxinv + work1(i) = max(zero, min(one, work1(i))) + work2(i) = one - work1(i) + psurf(i) = pgr(i) + end do + + do k=1,levs + do i=1,im + dudt(i,k) = zero + dvdt(i,k) = zero + dtdt(i,k) = zero + enddo + enddo + do n=1,ntrac + do k=1,levs + do i=1,im + dqdt(i,k,n) = zero + enddo + enddo + enddo + + end subroutine GFS_suite_interstitial_1_run + + end module GFS_suite_interstitial_1 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_1.meta b/physics/GFS_suite_interstitial_1.meta new file mode 100644 index 000000000..a465ed320 --- /dev/null +++ b/physics/GFS_suite_interstitial_1.meta @@ -0,0 +1,165 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_1 + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_1_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[dtf] + standard_name = timestep_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[slmsk] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[area] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dxmin] + standard_name = min_grid_scale + long_name = minimum scaling factor for critical relative humidity + units = m2 rad-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[dxinv] + standard_name = reciprocal_of_grid_scale_range + long_name = inverse scaling factor for critical relative humidity + units = rad2 m-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[pgr] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[islmsk] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[psurf] + standard_name = surface_air_pressure_diag + long_name = surface air pressure diagnostic + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[dudt] + standard_name = process_split_cumulative_tendency_of_x_wind + long_name = updated tendency of the x wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dvdt] + standard_name = process_split_cumulative_tendency_of_y_wind + long_name = updated tendency of the y wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dtdt] + standard_name = process_split_cumulative_tendency_of_air_temperature + long_name = updated tendency of the temperature + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dqdt] + standard_name = process_split_cumulative_tendency_of_tracers + long_name = updated tendency of the tracers + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = out +[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 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_2.F90 b/physics/GFS_suite_interstitial_2.F90 new file mode 100644 index 000000000..c72e5c7b2 --- /dev/null +++ b/physics/GFS_suite_interstitial_2.F90 @@ -0,0 +1,236 @@ +!> \file GFS_suite_interstitial_2.f90 +!! Contains code related used to calculate radiation-based and PBL-based diagnostics that are executed after radiation time interpolation and before the surface layer. + + module GFS_suite_interstitial_2 + + use machine, only: kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + logical :: linit_mod = .false. + + contains + +!> \section arg_table_GFS_suite_interstitial_2_run Argument Table +!! \htmlinclude GFS_suite_interstitial_2_run.html +!! + subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, flag_cice, shal_cnv, old_monin, mstrat, & + do_shoc, frac_grid, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, cice, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, & + work1, work2, prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, suntim, adjsfculw, adjsfculw_lnd, & + adjsfculw_ice, adjsfculw_wat, dlwsfc, ulwsfc, psmean, dtend, dtidx, index_of_process_longwave, index_of_process_shortwave, & + index_of_process_pbl, index_of_process_dcnv, index_of_process_scnv, index_of_process_mp, index_of_temperature, & + ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, use_LW_jacobian, htrlwu, errmsg, errflg) + + implicit none + + ! interface variables + integer, intent(in ) :: im, levs, imfshalcnv + logical, intent(in ) :: lssav, ldiag3d, lsidea, shal_cnv + logical, intent(in ) :: old_monin, mstrat, do_shoc, frac_grid, use_LW_jacobian + real(kind=kind_phys), intent(in ) :: dtf, cp, hvap + + logical, intent(in ), dimension(:) :: flag_cice + real(kind=kind_phys), intent(in ), dimension(:) :: ctei_rm + real(kind=kind_phys), intent(in ), dimension(:) :: xcosz, adjsfcdsw, adjsfcdlw, pgr, xmu, work1, work2 + real(kind=kind_phys), intent(in ), dimension(:) :: ulwsfc_cice + real(kind=kind_phys), intent(in ), dimension(:) :: cice + real(kind=kind_phys), intent(in ), dimension(:,:) :: htrsw, htrlw, htrlwu, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, prslk + real(kind=kind_phys), intent(in ), dimension(:,:) :: prsi + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: lwhd + integer, intent(inout), dimension(:) :: kinver + real(kind=kind_phys), intent(inout), dimension(:) :: suntim, dlwsfc, ulwsfc, psmean, ctei_rml, ctei_r + real(kind=kind_phys), intent(in ), dimension(:) :: adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat + real(kind=kind_phys), intent(inout), dimension(:) :: adjsfculw + + ! dtend is only allocated if ldiag3d is .true. + real(kind=kind_phys), optional, intent(inout), dimension(:,:,:) :: dtend + integer, intent(in), dimension(:,:) :: dtidx + integer, intent(in) :: index_of_process_longwave, index_of_process_shortwave, & + index_of_process_pbl, index_of_process_dcnv, index_of_process_scnv, & + index_of_process_mp, index_of_temperature + + logical, intent(in ), dimension(:) :: dry, icy, wet + real(kind=kind_phys), intent(in ), dimension(:) :: frland + real(kind=kind_phys), intent(in ) :: huge + + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! local variables + real(kind=kind_phys), parameter :: czmin = 0.0001_kind_phys ! cos(89.994) + integer :: i, k, idtend + real(kind=kind_phys) :: tem1, tem2, tem, hocp + logical, dimension(im) :: invrsn + real(kind=kind_phys), dimension(im) :: tx1, tx2 + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: qmin = 1.0e-10_kind_phys, epsln=1.0e-10_kind_phys + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + hocp = hvap/cp + + if (lssav) then ! --- ... accumulate/save output variables + +! --- ... sunshine duration time is defined as the length of time (in mdl output +! interval) that solar radiation falling on a plane perpendicular to the +! direction of the sun >= 120 w/m2 + + do i = 1, im + if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg + tem1 = adjsfcdsw(i) / xcosz(i) + if ( tem1 >= 120.0_kind_phys ) then + suntim(i) = suntim(i) + dtf + endif + endif + enddo + +! --- ... sfc lw fluxes used by atmospheric model are saved for output + if (frac_grid) then + do i=1,im + tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell + if (flag_cice(i)) then + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + ulwsfc_cice(i) * tem & + + adjsfculw_wat(i) * (one - frland(i) - tem) + else + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + adjsfculw_ice(i) * tem & + + adjsfculw_wat(i) * (one - frland(i) - tem) + endif + enddo + else + do i=1,im + if (dry(i)) then ! all land + adjsfculw(i) = adjsfculw_lnd(i) + elseif (icy(i)) then ! ice (and water) + tem = one - cice(i) + if (flag_cice(i)) then + if (wet(i) .and. adjsfculw_wat(i) /= huge) then + adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_wat(i)*tem + else + adjsfculw(i) = ulwsfc_cice(i) + endif + else + if (wet(i) .and. adjsfculw_wat(i) /= huge) then + adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_wat(i)*tem + else + adjsfculw(i) = adjsfculw_ice(i) + endif + endif + else ! all water + adjsfculw(i) = adjsfculw_wat(i) + endif + enddo + endif + + do i=1,im + dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf + ulwsfc(i) = ulwsfc(i) + adjsfculw(i)*dtf + psmean(i) = psmean(i) + pgr(i)*dtf ! mean surface pressure + enddo + + if (ldiag3d) then + if (lsidea) then + idtend = dtidx(index_of_temperature,index_of_process_longwave) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,1)*dtf + endif + + idtend = dtidx(index_of_temperature,index_of_process_shortwave) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,2)*dtf + endif + + idtend = dtidx(index_of_temperature,index_of_process_pbl) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,3)*dtf + endif + + idtend = dtidx(index_of_temperature,index_of_process_dcnv) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,4)*dtf + endif + + idtend = dtidx(index_of_temperature,index_of_process_scnv) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,5)*dtf + endif + + idtend = dtidx(index_of_temperature,index_of_process_mp) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,6)*dtf + endif + else + idtend = dtidx(index_of_temperature,index_of_process_longwave) + if(idtend>=1) then + if (use_LW_jacobian) then + dtend(:,:,idtend) = dtend(:,:,idtend) + htrlwu(:,:)*dtf + else + dtend(:,:,idtend) = dtend(:,:,idtend) + htrlw(:,:)*dtf + endif + endif + + idtend = dtidx(index_of_temperature,index_of_process_shortwave) + if(idtend>=1) then + do k=1,levs + do i=1,im + dtend(i,k,idtend) = dtend(i,k,idtend) + htrsw(i,k)*dtf*xmu(i) + enddo + enddo + endif + endif + endif + endif ! end if_lssav_block + + do i=1, im + invrsn(i) = .false. + tx1(i) = zero + tx2(i) = 10.0_kind_phys + ctei_r(i) = 10.0_kind_phys + enddo + + if ((((imfshalcnv == 0 .and. shal_cnv) .or. old_monin) .and. mstrat) & + .or. do_shoc) then + ctei_rml(:) = ctei_rm(1)*work1(:) + ctei_rm(2)*work2(:) + do k=1,levs/2 + do i=1,im + if (prsi(i,1)-prsi(i,k+1) < 0.35_kind_phys*prsi(i,1) & + .and. (.not. invrsn(i))) then + tem = (tgrs(i,k+1) - tgrs(i,k)) & + / (prsl(i,k) - prsl(i,k+1)) + + if (((tem > 0.0001_kind_phys) .and. (tx1(i) < zero)) .or. & + ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) then + invrsn(i) = .true. + + if (qgrs_water_vapor(i,k) > qgrs_water_vapor(i,k+1)) then + tem1 = tgrs(i,k+1) + hocp*max(qgrs_water_vapor(i,k+1),qmin) + tem2 = tgrs(i,k) + hocp*max(qgrs_water_vapor(i,k),qmin) + + tem1 = tem1 / prslk(i,k+1) - tem2 / prslk(i,k) + +! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI + ctei_r(i) = (one/hocp)*tem1/(qgrs_water_vapor(i,k+1)-qgrs_water_vapor(i,k) & + + qgrs_cloud_water(i,k+1)-qgrs_cloud_water(i,k)) + else + ctei_r(i) = 10.0_kind_phys + endif + + if ( ctei_rml(i) > ctei_r(i) ) then + kinver(i) = k + else + kinver(i) = levs + endif + endif + + tx2(i) = tx1(i) + tx1(i) = tem + endif + enddo + enddo + endif + + end subroutine GFS_suite_interstitial_2_run + + end module GFS_suite_interstitial_2 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_2.meta b/physics/GFS_suite_interstitial_2.meta new file mode 100644 index 000000000..1f4300574 --- /dev/null +++ b/physics/GFS_suite_interstitial_2.meta @@ -0,0 +1,488 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_2 + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_2_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[lssav] + standard_name = flag_for_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[lsidea] + standard_name = flag_for_integrated_dynamics_through_earths_atmosphere + long_name = flag for idealized physics + units = flag + dimensions = () + type = logical + intent = in +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[shal_cnv] + standard_name = flag_for_simplified_arakawa_schubert_shallow_convection + long_name = flag for calling shallow convection + units = flag + dimensions = () + type = logical + intent = in +[old_monin] + standard_name = flag_for_old_PBL_scheme + long_name = flag for using old PBL schemes + units = flag + dimensions = () + type = logical + intent = in +[mstrat] + standard_name = flag_for_moorthi_stratus + long_name = flag for moorthi approach for stratus + units = flag + dimensions = () + type = logical + intent = in +[do_shoc] + standard_name = flag_for_shoc + long_name = flag for SHOC + units = flag + dimensions = () + type = logical + intent = in +[frac_grid] + standard_name = flag_for_fractional_landmask + long_name = flag for fractional grid + units = flag + dimensions = () + type = logical + intent = in +[imfshalcnv] + standard_name = control_for_shallow_convection_scheme + long_name = flag for mass-flux shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[dtf] + standard_name = timestep_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[xcosz] + standard_name = instantaneous_cosine_of_zenith_angle + long_name = cosine of zenith angle at current time + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfcdsw] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfcdlw] + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cice] + standard_name = sea_ice_area_fraction_of_sea_area_fraction + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[pgr] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ulwsfc_cice] + standard_name = surface_upwelling_longwave_flux_from_coupled_process + long_name = surface upwelling longwave flux for coupling + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lwhd] + standard_name = tendency_of_air_temperature_due_to_integrated_dynamics_through_earths_atmosphere + long_name = idea sky lw heating rates + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,6) + type = real + kind = kind_phys + intent = in +[htrsw] + standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep + long_name = total sky sw heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[htrlw] + standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep + long_name = total sky lw heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[xmu] + standard_name = zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes + long_name = zenith angle temporal adjustment factor for shortwave fluxes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ctei_rm] + standard_name = tunable_parameter_for_critical_cloud_top_entrainment_instability_criteria + long_name = critical cloud top entrainment instability criteria + units = none + dimensions = (2) + type = real + kind = kind_phys + intent = in +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qgrs_water_vapor] + standard_name = specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qgrs_cloud_water] + standard_name = cloud_liquid_water_mixing_ratio + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[prslk] + standard_name = dimensionless_exner_function + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[suntim] + standard_name = duration_of_sunshine + long_name = sunshine duration time + units = s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[use_LW_jacobian] + standard_name = flag_to_calc_RRTMGP_LW_jacobian + long_name = logical flag to control RRTMGP LW calculation + units = flag + dimensions = () + type = logical + intent = in +[htrlwu] + standard_name = updated_tendency_of_air_temperature_due_to_longwave_heating_on_physics_timestep + long_name = total sky longwave heating rate on physics time step + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[adjsfculw] + standard_name = surface_upwelling_longwave_flux + long_name = surface upwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[adjsfculw_lnd] + standard_name = surface_upwelling_longwave_flux_over_land + long_name = surface upwelling longwave flux at current time over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfculw_ice] + standard_name = surface_upwelling_longwave_flux_over_ice + long_name = surface upwelling longwave flux at current time over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfculw_wat] + standard_name = surface_upwelling_longwave_flux_over_water + long_name = surface upwelling longwave flux at current time over water + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dlwsfc] + standard_name = cumulative_surface_downwelling_longwave_flux_multiplied_by_timestep + long_name = cumulative surface downwelling LW flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ulwsfc] + standard_name = cumulative_surface_upwelling_longwave_flux_multiplied_by_timestep + long_name = cumulative surface upwelling LW flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[psmean] + standard_name = cumulative_surface_pressure_multiplied_by_timestep + long_name = cumulative surface pressure multiplied by timestep + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = inout +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_process_longwave] + standard_name = index_of_longwave_heating_process_in_cumulative_change_index + long_name = index of longwave heating process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_shortwave] + standard_name = index_of_shortwave_heating_process_in_cumulative_change_index + long_name = index of shortwave heating process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_pbl] + standard_name = index_of_subgrid_scale_vertical_mixing_process_in_cumulative_change_index + long_name = index of subgrid scale vertical mixing process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_dcnv] + standard_name = index_of_deep_convection_process_process_in_cumulative_change_index + long_name = index of deep convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_scnv] + standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index + long_name = index of shallow convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_mp] + standard_name = index_of_microphysics_process_process_in_cumulative_change_index + long_name = index of microphysics transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_temperature] + standard_name = index_of_temperature_in_cumulative_change_index + long_name = index of temperature in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[ctei_rml] + standard_name = grid_sensitive_critical_cloud_top_entrainment_instability_criteria + long_name = grid sensitive critical cloud top entrainment instability criteria + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ctei_r] + standard_name = cloud_top_entrainment_instability_value + long_name = cloud top entrainment instability value + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[kinver] + standard_name = index_of_highest_temperature_inversion + long_name = index of highest temperature inversion + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[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 +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[frland] + standard_name = land_area_fraction_for_microphysics + long_name = land area fraction used in microphysics schemes + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[huge] + standard_name = netcdf_float_fillvalue + long_name = definition of NetCDF float FillValue + units = none + dimensions = () + type = real + kind = kind_phys + 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 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_3.F90 b/physics/GFS_suite_interstitial_3.F90 new file mode 100644 index 000000000..79ab481ec --- /dev/null +++ b/physics/GFS_suite_interstitial_3.F90 @@ -0,0 +1,195 @@ +!> \file GFS_suite_interstitial_3.F90 +!! Contains code to setup convectively-transported tracers, calculate critical relative humidity, and save cloud number concentrations + + module GFS_suite_interstitial_3 + + contains + +!> \section arg_table_GFS_suite_interstitial_3_run Argument Table +!! \htmlinclude GFS_suite_interstitial_3_run.html +!! + subroutine GFS_suite_interstitial_3_run (otsptflag, & + im, levs, nn, cscnv, & + satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & + ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & + xlon, xlat, gt0, gq0, imp_physics, imp_physics_mg, & + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & + imp_physics_gfdl, imp_physics_thompson, dtidx, ntlnc, & + imp_physics_wsm6, imp_physics_fer_hires, prsi, ntinc, & + imp_physics_nssl, & + prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & + work1, work2, kpbl, kinver, ras, me, save_lnc, save_inc, & + ldiag3d, qdiag3d, index_of_process_conv_trans, & + clw, rhc, save_qc, save_qi, save_tcp, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport (size ntrac) + integer, intent(in ) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, ntsw,& + ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & + imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & + imp_physics_nssl, me, index_of_process_conv_trans + integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver + logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras + + integer, intent(in) :: ntinc, ntlnc + logical, intent(in) :: ldiag3d, qdiag3d + integer, dimension(:,:), intent(in) :: dtidx + real, dimension(:,:), intent(out) :: save_lnc, save_inc + + real(kind=kind_phys), intent(in ) :: rhcbot, rhcmax, rhcpbl, rhctop + real(kind=kind_phys), intent(in ), dimension(:) :: work1, work2 + real(kind=kind_phys), intent(in ), dimension(:,:) :: prsl, prslk + real(kind=kind_phys), intent(in ), dimension(:,:) :: prsi + real(kind=kind_phys), intent(in ), dimension(:) :: xlon, xlat + real(kind=kind_phys), intent(in ), dimension(:,:) :: gt0 + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: gq0 + + real(kind=kind_phys), intent(inout), dimension(:,:) :: rhc, save_qc + ! save_qi is not allocated for Zhao-Carr MP + real(kind=kind_phys), intent(inout), dimension(:,:) :: save_qi + real(kind=kind_phys), intent(inout), dimension(:,:) :: save_tcp + real(kind=kind_phys), intent(inout), dimension(:,:,:) :: clw + + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! local variables + integer :: i,k,n,tracers,kk + real(kind=kind_phys) :: tem, tem1, tem2 + real(kind=kind_phys), dimension(im) :: tx1, tx2, tx3, tx4 + + !real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.04, & + ! turnrhcrit = 0.900, turnrhcrit_upper = 0.150 + ! in the following inverse of slope_mg and slope_upmg are specified + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: slope_mg = 50.0_kind_phys, & + slope_upmg = 25.0_kind_phys + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (cscnv .or. satmedmf .or. trans_trac .or. ras) then + tracers = 2 + do n=2,ntrac +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & +! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & +! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + IF ( otsptflag(n) ) THEN + tracers = tracers + 1 + do k=1,levs + do i=1,im + clw(i,k,tracers) = gq0(i,k,n) + enddo + enddo + endif + enddo + endif ! end if_ras or cfscnv or samf + + if (ntcw > 0) then + if (imp_physics == imp_physics_mg .and. rhcpbl < 0.5_kind_phys) then ! compute rhc for GMAO macro physics cloud pdf + do i=1,im + tx1(i) = one / prsi(i,1) + tx2(i) = one - rhcmax*work1(i)-rhcbot*work2(i) + + kk = min(kinver(i), max(2,kpbl(i))) + tx3(i) = prsi(i,kk)*tx1(i) + tx4(i) = rhcpbl - rhctop*abs(cos(xlat(i))) + enddo + do k = 1, levs + do i = 1, im + tem = prsl(i,k) * tx1(i) + tem1 = min(max((tem-tx3(i))*slope_mg, -20.0_kind_phys), 20.0_kind_phys) + ! Using rhcpbl and rhctop from the namelist instead of 0.3 and 0.2 + ! and rhcbot represents pbl top critical relative humidity + tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0_kind_phys), 20.0_kind_phys) ! Anning + if (islmsk(i) > 0) then + tem1 = one / (one+exp(tem1+tem1)) + else + tem1 = 2.0_kind_phys / (one+exp(tem1+tem1)) + endif + tem2 = one / (one+exp(tem2)) + + rhc(i,k) = min(rhcmax, max(0.7_kind_phys, one-tx2(i)*tem1*tem2)) + enddo + enddo + else + do k=1,levs + do i=1,im + kk = max(10,kpbl(i)) + if (k < kk) then + tem = rhcbot - (rhcbot-rhcpbl) * (one-prslk(i,k)) / (one-prslk(i,kk)) + else + tem = rhcpbl - (rhcpbl-rhctop) * (prslk(i,kk)-prslk(i,k)) / prslk(i,kk) + endif + tem = rhcmax * work1(i) + tem * work2(i) + rhc(i,k) = max(zero, min(one,tem)) + enddo + enddo + endif + else + rhc(:,:) = 1.0 + endif + + if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_zhao_carr_pdf) then ! zhao-carr microphysics + !GF* move to GFS_MP_generic_pre (from gscond/precpd) + ! do i=1,im + ! psautco_l(i) = Model%psautco(1)*work1(i) + Model%psautco(2)*work2(i) + ! prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) + ! enddo + !*GF + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntcw) + enddo + enddo + elseif (imp_physics == imp_physics_gfdl) then + clw(1:im,:,1) = gq0(1:im,:,ntcw) + elseif (imp_physics == imp_physics_thompson) then + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! ice + clw(i,k,2) = gq0(i,k,ntcw) ! water + save_tcp(i,k) = gt0(i,k) + enddo + enddo + if(ltaerosol) then + save_qi(:,:) = clw(:,:,1) + save_qc(:,:) = clw(:,:,2) + else + save_qi(:,:) = clw(:,:,1) + endif + else if (imp_physics == imp_physics_nssl ) then + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! cloud ice + clw(i,k,2) = gq0(i,k,ntcw) ! cloud droplets + enddo + enddo + save_qi(:,:) = clw(:,:,1) + save_qc(:,:) = clw(:,:,2) + elseif (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_mg .or. imp_physics == imp_physics_fer_hires) then + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! ice + clw(i,k,2) = gq0(i,k,ntcw) ! water + enddo + enddo + endif + + if(imp_physics == imp_physics_thompson .and. ldiag3d .and. qdiag3d) then + if(dtidx(100+ntlnc,index_of_process_conv_trans)>0) then + save_lnc = gq0(:,:,ntlnc) + endif + if(dtidx(100+ntinc,index_of_process_conv_trans)>0) then + save_inc = gq0(:,:,ntinc) + endif + endif + + end subroutine GFS_suite_interstitial_3_run + + end module GFS_suite_interstitial_3 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_3.meta b/physics/GFS_suite_interstitial_3.meta new file mode 100644 index 000000000..22a11d0ea --- /dev/null +++ b/physics/GFS_suite_interstitial_3.meta @@ -0,0 +1,458 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_3 + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_3_run + type = scheme +[otsptflag] + standard_name = flag_convective_tracer_transport_interstitial + long_name = flag for interstitial tracer transport + units = flag + dimensions = (number_of_tracers) + type = logical + intent = in +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[nn] + standard_name = number_of_tracers_for_convective_transport + long_name = number of tracers for convective transport + units = count + dimensions = () + type = integer + intent = in +[cscnv] + standard_name = flag_for_Chikira_Sugiyama_deep_convection + long_name = flag for Chikira-Sugiyama convection + units = flag + dimensions = () + type = logical + intent = in +[satmedmf] + standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL + long_name = flag for scale-aware TKE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in +[trans_trac] + standard_name = flag_for_convective_transport_of_tracers + long_name = flag for convective transport of tracers + units = flag + dimensions = () + type = logical + intent = in +[do_shoc] + standard_name = flag_for_shoc + long_name = flag for SHOC + units = flag + dimensions = () + type = logical + intent = in +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics + units = flag + dimensions = () + type = logical + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[ntclamt] + standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgl] + standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in +[ntgnc] + standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in +[xlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_mg] + standard_name = identifier_for_morrison_gettelman_microphysics_scheme + long_name = choice of Morrison-Gettelman microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr] + standard_name = identifier_for_zhao_carr_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr_pdf] + standard_name = identifier_for_zhao_carr_pdf_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme with PDF clouds + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_gfdl] + standard_name = identifier_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_thompson] + standard_name = identifier_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_wsm6] + standard_name = identifier_for_wsm6_microphysics_scheme + long_name = choice of WSM6 microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_fer_hires] + standard_name = identifier_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prslk] + standard_name = dimensionless_exner_function + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[rhcbot] + standard_name = critical_relative_humidity_at_surface + long_name = critical relative humidity at the surface + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[rhcpbl] + standard_name = critical_relative_humidity_at_PBL_top + long_name = critical relative humidity at the PBL top + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[rhctop] + standard_name = critical_relative_humidity_at_toa + long_name = critical relative humidity at the top of atmosphere + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[rhcmax] + standard_name = max_critical_relative_humidity + long_name = maximum critical relative humidity + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = vertical index at top atmospheric boundary layer + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[kinver] + standard_name = index_of_highest_temperature_inversion + long_name = index of highest temperature inversion + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[ras] + standard_name = flag_for_relaxed_arakawa_schubert_deep_convection + long_name = flag for ras convection scheme + units = flag + dimensions = () + type = logical + intent = in +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = inout +[rhc] + standard_name = critical_relative_humidity + long_name = critical relative humidity + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_qc] + standard_name = cloud_condensed_water_mixing_ratio_save + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_qi] + standard_name = ice_water_mixing_ratio_save + long_name = cloud ice water mixing ratio before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_tcp] + standard_name = air_temperature_save_from_convective_parameterization + long_name = air temperature after cumulus parameterization + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[index_of_process_conv_trans] + standard_name = index_of_convective_transport_process_in_cumulative_change_index + long_name = index of convective transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[save_lnc] + standard_name = liquid_cloud_number_concentration_save + long_name = liquid cloud number concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_inc] + standard_name = ice_cloud_number_concentration_save + long_name = ice cloud number concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[ntlnc] + standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array + long_name = tracer index for liquid number concentration + units = index + dimensions = () + type = integer + intent = in +[ntinc] + standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array + long_name = tracer index for ice number concentration + units = index + dimensions = () + type = integer + intent = in +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[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 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_4.F90 b/physics/GFS_suite_interstitial_4.F90 new file mode 100644 index 000000000..cbabb991b --- /dev/null +++ b/physics/GFS_suite_interstitial_4.F90 @@ -0,0 +1,293 @@ +!> \file GFS_suite_interstitial_4.F90 +!! Contains code to calculate tendencies of tracers due to convective transport, updates tracers after convective transport, and updates cloud condensation nuclei. + + module GFS_suite_interstitial_4 + + contains + +!> \section arg_table_GFS_suite_interstitial_4_run Argument Table +!! \htmlinclude GFS_suite_interstitial_4_run.html +!! + subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & + ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl, nssl_invertccn, nssl_ccn_on, & + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& + index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nssl_cccn, nwfa, spechum, ldiag3d, & + qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, errmsg, errflg) + + use machine, only: kind_phys + use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber + + implicit none + + ! interface variables + + logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport by updraft and + integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & + ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl + + logical, intent(in) :: ltaerosol, convert_dry_rho + logical, intent(in) :: nssl_ccn_on, nssl_invertccn + + real(kind=kind_phys), intent(in ) :: con_pi, dtf + real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc + ! save_qi is not allocated for Zhao-Carr MP + real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qi, save_lnc, save_inc + + ! dtend and dtidx are only allocated if ldiag3d + logical, intent(in) :: ldiag3d, qdiag3d + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: dtend + integer, dimension(:,:), intent(in) :: dtidx + integer, intent(in) :: index_of_process_conv_trans,ntk,ntke + + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: gq0 + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: clw + real(kind=kind_phys), dimension(:,:), intent(in) :: prsl + real(kind=kind_phys), intent(in) :: con_rd, con_eps, nssl_cccn + real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp + real(kind=kind_phys), dimension(:,:), intent(in) :: spechum + + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! local variables + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + integer :: i,k,n,tracers,idtend + real(kind=kind_phys) :: liqm, icem, xccn, xcwmas, xccw, xcimas, qccn + + real(kind=kind_phys) :: rho, orho + real(kind=kind_phys), dimension(im,levs) :: qv_mp !< kg kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: qc_mp !< kg kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: qi_mp !< kg kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: nc_mp !< kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: ni_mp !< kg-1 (dry mixing ratio) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! This code was previously in GFS_SCNV_generic_post, but it really belongs + ! here, because it fixes the convective transportable_tracers mess for Zhao-Carr + ! and GFDL MP from GFS_suite_interstitial_3. This whole code around clw(:,:,2) + ! being set to -999 for Zhao-Carr MP (which doesn't have cloud ice) and GFDL-MP + ! (which does have cloud ice, but for some reason it was decided to code it up + ! in the same way as for Zhao-Carr, nowadays unnecessary and confusing) needs + ! to be cleaned up. The convection schemes doing something different internally + ! based on clw(i,k,2) being -999.0 or not is not a good idea. + do k=1,levs + do i=1,im + if (clw(i,k,2) <= -999.0) clw(i,k,2) = 0.0 + enddo + enddo + + if(ldiag3d) then + if(ntk>0 .and. ntk<=size(clw,3)) then + idtend=dtidx(100+ntke,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,ntk)-gq0(:,:,ntk) + endif + endif + if(ntcw>0) then + if (imp_physics == imp_physics_zhao_carr .or. & + imp_physics == imp_physics_zhao_carr_pdf .or. & + imp_physics == imp_physics_gfdl) then + idtend=dtidx(100+ntcw,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)+clw(:,:,2) - gq0(:,:,ntcw) + endif + else if(ntiw>0) then + idtend=dtidx(100+ntiw,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)-gq0(:,:,ntiw) + endif + idtend=dtidx(100+ntcw,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,2)-gq0(:,:,ntcw) + endif + else + idtend=dtidx(100+ntcw,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)+clw(:,:,2) - gq0(:,:,ntcw) + endif + endif + endif + endif + +! --- update the tracers due to deep & shallow cumulus convective transport +! (except for suspended water and ice) + + if (tracers_total > 0) then + tracers = 2 + do n=2,ntrac +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & +! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & +! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc & +! .and. & +! n /= nthl .and. n /= nthnc .and. n /= ntgv .and. & +! n /= nthv .and. n /= ntccn & +! ) then + IF ( otsptflag(n) ) THEN + tracers = tracers + 1 + if(n/=ntk .and. n/=ntlnc .and. n/=ntinc .and. n /= ntcw .and. n /= ntiw) then + idtend=dtidx(100+n,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,tracers)-gq0(:,:,n) + endif + endif + do k=1,levs + do i=1,im + gq0(i,k,n) = clw(i,k,tracers) + enddo + enddo + endif + enddo + endif + + if (ntcw > 0) then + +! for microphysics + if (imp_physics == imp_physics_zhao_carr .or. & + imp_physics == imp_physics_zhao_carr_pdf .or. & + imp_physics == imp_physics_gfdl) then + gq0(1:im,:,ntcw) = clw(1:im,:,1) + clw(1:im,:,2) + + elseif (ntiw > 0) then + do k=1,levs + do i=1,im + gq0(i,k,ntiw) = clw(i,k,1) ! ice + gq0(i,k,ntcw) = clw(i,k,2) ! water + enddo + enddo + + if ( imp_physics == imp_physics_nssl ) then + liqm = con_pi/6.*1.e3*(18.e-6)**3 ! 4./3.*con_pi*1.e-12 + icem = con_pi/6.*1.e3*(120.e-6)**3 ! 4./3.*con_pi*3.2768*1.e-14*890. + qccn = nssl_cccn/1.225 !1.225 is a reference air density and should match what is used in module_mp_nssl_2mom.F90 (rho00) + do k=1,levs + do i=1,im + ! check number of available ccn + IF ( nssl_ccn_on ) THEN + IF ( nssl_invertccn ) THEN + xccn = qccn - gq0(i,k,ntccn) + ELSE + xccn = gq0(i,k,ntccn) + ENDIF + ELSE + xccn = Max(0.0, qccn - gq0(i,k,ntlnc)) + ENDIF + + IF ( gq0(i,k,ntlnc) > 0.0 .and. save_qc(i,k) > 0.0 ) THEN + xcwmas = Max( liqm, clw(i,k,2)/gq0(i,k,ntlnc) ) + ELSE + xcwmas = liqm + ENDIF + + IF ( gq0(i,k,ntinc) > 0.0 .and. save_qi(i,k) > 0.0 ) THEN + xcimas = Max( liqm, clw(i,k,1)/gq0(i,k,ntinc) ) + ELSE + xcimas = icem + ENDIF + + IF ( xccn > 0.0 ) THEN + xccw = Min( xccn, max(0.0, (clw(i,k,2)-save_qc(i,k))) / xcwmas ) + gq0(i,k,ntlnc) = gq0(i,k,ntlnc) + xccw + IF ( nssl_ccn_on ) THEN + IF ( nssl_invertccn ) THEN + ! ccn are activated CCN, so add + gq0(i,k,ntccn) = gq0(i,k,ntccn) + xccw + ELSE + ! ccn are unactivated CCN, so subtract + gq0(i,k,ntccn) = gq0(i,k,ntccn) - xccw + ENDIF + ENDIF + ENDIF + + gq0(i,k,ntinc) = gq0(i,k,ntinc) & + + max(0.0, (clw(i,k,1)-save_qi(i,k))) / xcimas + enddo + enddo + endif + + if (imp_physics == imp_physics_thompson .and. (ntlnc>0 .or. ntinc>0)) then + if_convert_dry_rho: if (convert_dry_rho) then + do k=1,levs + do i=1,im + !> - Convert specific humidity to dry mixing ratio + qv_mp(i,k) = spechum(i,k) / (one-spechum(i,k)) + !> - Density of air in kg m-3 and inverse density + rho = con_eps*prsl(i,k) / (con_rd*save_tcp(i,k)*(qv_mp(i,k)+con_eps)) + orho = one/rho + if (ntlnc>0) then + !> - Convert moist mixing ratio to dry mixing ratio + qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) / (one-spechum(i,k)) + !> - Convert number concentration from moist to dry + nc_mp(i,k) = gq0(i,k,ntlnc) / (one-spechum(i,k)) + nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + !> - Convert number concentrations from dry to moist + gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) + endif + if (ntinc>0) then + !> - Convert moist mixing ratio to dry mixing ratio + qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) / (one-spechum(i,k)) + !> - Convert number concentration from moist to dry + ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) + ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + !> - Convert number concentrations from dry to moist + gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) + endif + enddo + enddo + else + do k=1,levs + do i=1,im + !> - Density of air in kg m-3 and inverse density + rho = con_eps*prsl(i,k) / (con_rd*save_tcp(i,k)*(spechum(i,k)+con_eps)) + orho = one/rho + if (ntlnc>0) then + !> - Update cloud water mixing ratio + qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) + !> - Update cloud water number concentration + gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + endif + if (ntinc>0) then + !> - Update cloud ice mixing ratio + qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) + !> - Update cloud ice number concentration + gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + endif + enddo + enddo + end if if_convert_dry_rho + if(ldiag3d .and. qdiag3d) then + idtend = dtidx(100+ntlnc,index_of_process_conv_trans) + if(idtend>0) then + dtend(:,:,idtend) = dtend(:,:,idtend) + gq0(:,:,ntlnc) - save_lnc + endif + idtend = dtidx(100+ntinc,index_of_process_conv_trans) + if(idtend>0) then + dtend(:,:,idtend) = dtend(:,:,idtend) + gq0(:,:,ntinc) - save_inc + endif + endif + endif + + else + do k=1,levs + do i=1,im + gq0(i,k,ntcw) = clw(i,k,1) + clw(i,k,2) + enddo + enddo + endif ! end if_ntiw + + else + do k=1,levs + do i=1,im + clw(i,k,1) = clw(i,k,1) + clw(i,k,2) + enddo + enddo + endif ! end if_ntcw + + end subroutine GFS_suite_interstitial_4_run + + end module GFS_suite_interstitial_4 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_4.meta b/physics/GFS_suite_interstitial_4.meta new file mode 100644 index 000000000..92870d95f --- /dev/null +++ b/physics/GFS_suite_interstitial_4.meta @@ -0,0 +1,391 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_4 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_4_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics + units = flag + dimensions = () + type = logical + intent = in +[tracers_total] + standard_name = number_of_total_tracers + long_name = total number of tracers + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[ntclamt] + standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgl] + standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in +[ntgnc] + standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in +[ntlnc] + standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array + long_name = tracer index for liquid number concentration + units = index + dimensions = () + type = integer + intent = in +[ntinc] + standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array + long_name = tracer index for ice number concentration + units = index + dimensions = () + type = integer + intent = in +[nn] + standard_name = number_of_tracers_for_convective_transport + long_name = number of tracers for convective transport + units = count + dimensions = () + type = integer + intent = in +[ntccn] + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_gfdl] + standard_name = identifier_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_thompson] + standard_name = identifier_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr] + standard_name = identifier_for_zhao_carr_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr_pdf] + standard_name = identifier_for_zhao_carr_pdf_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme with PDF clouds + units = flag + dimensions = () + type = integer + intent = in +[convert_dry_rho] + standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air + long_name = flag for converting hydrometeors from moist to dry air + units = flag + dimensions = () + type = logical + intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[dtf] + standard_name = timestep_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[save_qc] + standard_name = cloud_condensed_water_mixing_ratio_save + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[save_qi] + standard_name = ice_water_mixing_ratio_save + long_name = cloud ice water mixing ratio before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[save_lnc] + standard_name = liquid_cloud_number_concentration_save + long_name = liquid cloud number concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[save_inc] + standard_name = ice_cloud_number_concentration_save + long_name = ice cloud number concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[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 +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = inout +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[save_tcp] + standard_name = air_temperature_save_from_convective_parameterization + long_name = air temperature after cumulus parameterization + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[nssl_cccn] + standard_name = nssl_ccn_concentration + long_name = CCN concentration + units = m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[nwfa] + standard_name = mass_number_concentration_of_hygroscopic_aerosols + long_name = number concentration of water-friendly aerosols + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spechum] + standard_name = specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = inout +[ntk] + standard_name = index_for_turbulent_kinetic_energy_convective_transport_tracer + long_name = index for turbulent kinetic energy in the convectively transported tracer array + units = index + dimensions = () + type = integer + intent = in +[ntke] + standard_name = index_of_turbulent_kinetic_energy_in_tracer_concentration_array + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[index_of_process_conv_trans] + standard_name = index_of_convective_transport_process_in_cumulative_change_index + long_name = index of convective transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[otsptflag] + standard_name = flag_convective_tracer_transport_interstitial + long_name = flag for interstitial tracer transport + units = flag + dimensions = (number_of_tracers) + 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 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_5.F90 b/physics/GFS_suite_interstitial_5.F90 new file mode 100644 index 000000000..c73345ea0 --- /dev/null +++ b/physics/GFS_suite_interstitial_5.F90 @@ -0,0 +1,43 @@ +!> \file GFS_suite_interstitial_5.F90 +!! Contains code to update cloud liquid and ice in the convective transportable tracer array before RAS convection. + + module GFS_suite_interstitial_5 + + contains + +!> \section arg_table_GFS_suite_interstitial_5_run Argument Table +!! \htmlinclude GFS_suite_interstitial_5_run.html +!! + subroutine GFS_suite_interstitial_5_run (im, levs, ntrac, ntcw, ntiw, nn, gq0, clw, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + integer, intent(in ) :: im, levs, ntrac, ntcw, ntiw, nn + + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: gq0 + + real(kind=kind_phys), intent(out), dimension(:,:,:) :: clw + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer :: i,k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! ice + clw(i,k,2) = gq0(i,k,ntcw) ! water + enddo + enddo + + end subroutine GFS_suite_interstitial_5_run + + end module GFS_suite_interstitial_5 diff --git a/physics/GFS_suite_interstitial_5.meta b/physics/GFS_suite_interstitial_5.meta new file mode 100644 index 000000000..9d32160a1 --- /dev/null +++ b/physics/GFS_suite_interstitial_5.meta @@ -0,0 +1,83 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_5 + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_5_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[nn] + standard_name = number_of_tracers_for_convective_transport + long_name = number of tracers for convective transport + units = count + dimensions = () + type = integer + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) + 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/GFS_suite_interstitial_phys_reset.F90 b/physics/GFS_suite_interstitial_phys_reset.F90 new file mode 100644 index 000000000..162fb870a --- /dev/null +++ b/physics/GFS_suite_interstitial_phys_reset.F90 @@ -0,0 +1,31 @@ +!> \file GFS_suite_interstitial_phys_reset.f90 +!! Contains code to reset physics-related interstitial variables in the GFS physics suite. + + module GFS_suite_interstitial_phys_reset + + contains + +!> \section arg_table_GFS_suite_interstitial_phys_reset_run Argument Table +!! \htmlinclude GFS_suite_interstitial_phys_reset_run.html +!! + subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Model, errmsg, errflg) + + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type + + implicit none + + ! interface variables + type(GFS_interstitial_type), intent(inout) :: Interstitial + type(GFS_control_type), intent(in ) :: Model + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + errmsg = '' + errflg = 0 + + call Interstitial%phys_reset(Model) + + end subroutine GFS_suite_interstitial_phys_reset_run + + end module GFS_suite_interstitial_phys_reset \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_phys_reset.meta b/physics/GFS_suite_interstitial_phys_reset.meta new file mode 100644 index 000000000..adebbc833 --- /dev/null +++ b/physics/GFS_suite_interstitial_phys_reset.meta @@ -0,0 +1,39 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_phys_reset + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_phys_reset_run + type = scheme +[Interstitial] + standard_name = GFS_interstitial_type_instance + long_name = derived type GFS_interstitial_type in FV3 + units = DDT + dimensions = () + type = GFS_interstitial_type + intent = inout +[Model] + standard_name = GFS_control_type_instance + long_name = Fortran DDT containing FV3-GFS model control parameters + units = DDT + dimensions = () + type = GFS_control_type + 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 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_rad_reset.F90 b/physics/GFS_suite_interstitial_rad_reset.F90 new file mode 100644 index 000000000..3d4903453 --- /dev/null +++ b/physics/GFS_suite_interstitial_rad_reset.F90 @@ -0,0 +1,31 @@ +!> \file GFS_suite_interstitial_rad_reset.f90 +!! Contains code to reset radiation-related interstitial variables + + module GFS_suite_interstitial_rad_reset + + contains + +!> \section arg_table_GFS_suite_interstitial_rad_reset_run Argument Table +!! \htmlinclude GFS_suite_interstitial_rad_reset_run.html +!! + subroutine GFS_suite_interstitial_rad_reset_run (Interstitial, Model, errmsg, errflg) + + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type + + implicit none + + ! interface variables + type(GFS_interstitial_type), intent(inout) :: Interstitial + type(GFS_control_type), intent(in) :: Model + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + + call Interstitial%rad_reset(Model) + + end subroutine GFS_suite_interstitial_rad_reset_run + + end module GFS_suite_interstitial_rad_reset \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_rad_reset.meta b/physics/GFS_suite_interstitial_rad_reset.meta new file mode 100644 index 000000000..91fd8cba7 --- /dev/null +++ b/physics/GFS_suite_interstitial_rad_reset.meta @@ -0,0 +1,38 @@ +[ccpp-table-properties] + name = GFS_suite_interstitial_rad_reset + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_rad_reset_run + type = scheme +[Interstitial] + standard_name = GFS_interstitial_type_instance + long_name = derived type GFS_interstitial_type in FV3 + units = DDT + dimensions = () + type = GFS_interstitial_type + intent = inout +[Model] + standard_name = GFS_control_type_instance + long_name = Fortran DDT containing FV3-GFS model control parameters + units = DDT + dimensions = () + type = GFS_control_type + 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 \ No newline at end of file diff --git a/physics/GFS_suite_stateout_reset.F90 b/physics/GFS_suite_stateout_reset.F90 new file mode 100644 index 000000000..313a0304c --- /dev/null +++ b/physics/GFS_suite_stateout_reset.F90 @@ -0,0 +1,43 @@ +!> \file GFS_suite_stateout_reset.f90 +!! Contains code to set the values of the physics-updated state to the before-physics state prior to actually being modified by physics. + + module GFS_suite_stateout_reset + + contains + +!> \section arg_table_GFS_suite_stateout_reset_run Argument Table +!! \htmlinclude GFS_suite_stateout_reset_run.html +!! + subroutine GFS_suite_stateout_reset_run (im, levs, ntrac, & + tgrs, ugrs, vgrs, qgrs, & + gt0 , gu0 , gv0 , gq0 , & + errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + integer, intent(in ) :: im + integer, intent(in ) :: levs + integer, intent(in ) :: ntrac + real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs + real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0 + real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + gt0(:,:) = tgrs(:,:) + gu0(:,:) = ugrs(:,:) + gv0(:,:) = vgrs(:,:) + gq0(:,:,:) = qgrs(:,:,:) + + end subroutine GFS_suite_stateout_reset_run + + end module GFS_suite_stateout_reset \ No newline at end of file diff --git a/physics/GFS_suite_stateout_reset.meta b/physics/GFS_suite_stateout_reset.meta new file mode 100644 index 000000000..fa4111e6b --- /dev/null +++ b/physics/GFS_suite_stateout_reset.meta @@ -0,0 +1,110 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_stateout_reset + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_stateout_reset_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gu0] + standard_name = x_wind_of_new_state + long_name = zonal wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gv0] + standard_name = y_wind_of_new_state + long_name = meridional wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[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 = out +[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 \ No newline at end of file diff --git a/physics/GFS_suite_stateout_update.F90 b/physics/GFS_suite_stateout_update.F90 new file mode 100644 index 000000000..2771c3e82 --- /dev/null +++ b/physics/GFS_suite_stateout_update.F90 @@ -0,0 +1,63 @@ +!> \file GFS_suite_stateout_update.f90 +!! Contains code to update the state variables due to process-split physics from accumulated tendencies during that phase. +!! Also, set bounds on the mass-weighted rime factor when using Ferrier-Aligo microphysics. + + module GFS_suite_stateout_update + + contains + +!> \section arg_table_GFS_suite_stateout_update_run Argument Table +!! \htmlinclude GFS_suite_stateout_update_run.html +!! + subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & + tgrs, ugrs, vgrs, qgrs, dudt, dvdt, dtdt, dqdt, & + gt0, gu0, gv0, gq0, ntiw, nqrimef, imp_physics, & + imp_physics_fer_hires, epsq, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in ) :: im + integer, intent(in ) :: levs + integer, intent(in ) :: ntrac + integer, intent(in ) :: imp_physics,imp_physics_fer_hires + integer, intent(in ) :: ntiw, nqrimef + real(kind=kind_phys), intent(in ) :: dtp, epsq + + real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs + real(kind=kind_phys), intent(in ), dimension(:,:) :: dudt, dvdt, dtdt + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: dqdt + real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0 + real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp + gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp + gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp + gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp + + if (imp_physics == imp_physics_fer_hires) then + do k=1,levs + do i=1,im + if(gq0(i,k,ntiw) > epsq) then + gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw)) + else + gq0(i,k,nqrimef) = 1. + end if + end do + end do + end if + + end subroutine GFS_suite_stateout_update_run + + end module GFS_suite_stateout_update \ No newline at end of file diff --git a/physics/GFS_suite_stateout_update.meta b/physics/GFS_suite_stateout_update.meta new file mode 100644 index 000000000..580482b71 --- /dev/null +++ b/physics/GFS_suite_stateout_update.meta @@ -0,0 +1,186 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_stateout_update + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_stateout_update_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[dudt] + standard_name = process_split_cumulative_tendency_of_x_wind + long_name = updated tendency of the x wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dvdt] + standard_name = process_split_cumulative_tendency_of_y_wind + long_name = updated tendency of the y wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dtdt] + standard_name = process_split_cumulative_tendency_of_air_temperature + long_name = updated tendency of the temperature + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dqdt] + standard_name = process_split_cumulative_tendency_of_tracers + long_name = updated tendency of the tracers + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gu0] + standard_name = x_wind_of_new_state + long_name = zonal wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gv0] + standard_name = y_wind_of_new_state + long_name = meridional wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[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 = out +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[nqrimef] + standard_name = index_of_mass_weighted_rime_factor_in_tracer_concentration_array + long_name = tracer index for mass weighted rime factor + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_fer_hires] + standard_name = identifier_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[epsq] + standard_name = minimum_value_of_specific_humidity + long_name = floor value for specific humidity + units = kg kg-1 + dimensions = () + type = real + kind = kind_phys + 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 \ No newline at end of file diff --git a/physics/GFS_surface_composites_inter.F90 b/physics/GFS_surface_composites_inter.F90 new file mode 100644 index 000000000..0e288691c --- /dev/null +++ b/physics/GFS_surface_composites_inter.F90 @@ -0,0 +1,71 @@ +!> \file GFS_surface_composites_inter.F90 +!! Contains code related to generating composites for all GFS surface schemes. + +module GFS_surface_composites_inter + + use machine, only: kind_phys + + implicit none + + private + + public GFS_surface_composites_inter_run + +contains + +!> \section arg_table_GFS_surface_composites_inter_run Argument Table +!! \htmlinclude GFS_surface_composites_inter_run.html +!! + subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, & + adjsfcdlw, gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat,& + adjsfcusw, adjsfcdsw, adjsfcnsw, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in ) :: im + logical, dimension(:), intent(in ) :: dry, icy, wet + real(kind=kind_phys), dimension(:), intent(in ) :: semis_wat, semis_lnd, semis_ice, & + adjsfcdlw, adjsfcdsw, adjsfcnsw + real(kind=kind_phys), dimension(:), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat + real(kind=kind_phys), dimension(:), intent(out) :: adjsfcusw + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! --- convert lw fluxes for land/ocean/sea-ice models - requires dcyc2t3 to set adjsfcdlw + ! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. + ! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. + ! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. + ! one needs to be aware that that the absorbed downward lw flux (used by land/ocean + ! models as downward flux) is not the same as adjsfcdlw but a value reduced by + ! the factor of emissivity. however, the net effects are the same when seeing + ! it either above the surface interface or below. + ! + ! - flux above the interface used by atmosphere model: + ! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw + ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) + ! - flux below the interface used by lnd/oc/ice models: + ! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 + ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) + ! surface upwelling shortwave flux at current time is in adjsfcusw + + ! --- ... define the downward lw flux absorbed by ground + do i=1,im + if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) + if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) + if (wet(i)) gabsbdlw_wat(i) = semis_wat(i) * adjsfcdlw(i) + adjsfcusw(i) = adjsfcdsw(i) - adjsfcnsw(i) + enddo + + end subroutine GFS_surface_composites_inter_run + +end module GFS_surface_composites_inter \ No newline at end of file diff --git a/physics/GFS_surface_composites_inter.meta b/physics/GFS_surface_composites_inter.meta new file mode 100644 index 000000000..00227a09b --- /dev/null +++ b/physics/GFS_surface_composites_inter.meta @@ -0,0 +1,133 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_surface_composites_inter + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_composites_inter_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + 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 +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[semis_wat] + standard_name = surface_longwave_emissivity_over_water + long_name = surface lw emissivity in fraction over water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[semis_lnd] + standard_name = surface_longwave_emissivity_over_land + long_name = surface lw emissivity in fraction over land + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[semis_ice] + standard_name = surface_longwave_emissivity_over_ice + long_name = surface lw emissivity in fraction over ice + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfcdlw] + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[gabsbdlw_lnd] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land + long_name = total sky surface downward longwave flux absorbed by the ground over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[gabsbdlw_ice] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ice + long_name = total sky surface downward longwave flux absorbed by the ground over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[gabsbdlw_wat] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_water + long_name = total sky surface downward longwave flux absorbed by the ground over water + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[adjsfcusw] + standard_name = surface_upwelling_shortwave_flux + long_name = surface upwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[adjsfcdsw] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfcnsw] + standard_name = surface_net_downwelling_shortwave_flux + long_name = surface net downwelling shortwave flux at current time + units = W m-2 + 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 + 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 \ No newline at end of file diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites_post.F90 similarity index 52% rename from physics/GFS_surface_composites.F90 rename to physics/GFS_surface_composites_post.F90 index 510b3f427..fd1bf29d0 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites_post.F90 @@ -1,380 +1,6 @@ -!> \file GFS_surface_composites.F90 +!> \file GFS_surface_composites_post.F90 !! Contains code related to generating composites for all GFS surface schemes. -module GFS_surface_composites_pre - - use machine, only: kind_phys - use physparam, only : iemsflg - - implicit none - - private - - public GFS_surface_composites_pre_init, GFS_surface_composites_pre_finalize, GFS_surface_composites_pre_run - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys - -! real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue - -contains - - subroutine GFS_surface_composites_pre_init () - end subroutine GFS_surface_composites_pre_init - - subroutine GFS_surface_composites_pre_finalize() - end subroutine GFS_surface_composites_pre_finalize - -!> \section arg_table_GFS_surface_composites_pre_run Argument Table -!! \htmlinclude GFS_surface_composites_pre_run.html -!! - subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, frac_grid, & - flag_cice, cplflx, cplice, cplwav2atm, landfrac, lakefrac, lakedepth, oceanfrac, frland, & - dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & - snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & - tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & - weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & - tisfc, tsurf_wat, tsurf_lnd, tsurf_ice, & - gflx_ice, tgice, islmsk, islmsk_cice, slmsk, qss, qss_wat, qss_lnd, qss_ice, & - min_lakeice, min_seaice, kdt, huge, errmsg, errflg) - - implicit none - - ! Interface variables - integer, intent(in ) :: im, lkm, kdt - logical, intent(in ) :: flag_init, flag_restart, frac_grid, cplflx, cplice, cplwav2atm - logical, dimension(:), intent(inout) :: flag_cice - logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet - real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac - real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice - real(kind=kind_phys), dimension(:), intent( out) :: frland - real(kind=kind_phys), dimension(:), intent(in ) :: snowd, tprcp, uustar, weasd, qss - - real(kind=kind_phys), dimension(:), intent(inout) :: tsfc, tsfco, tsfcl, tisfc - real(kind=kind_phys), dimension(:), intent(inout) :: snowd_lnd, snowd_ice, tprcp_wat, & - tprcp_lnd, tprcp_ice, tsfc_wat, tsurf_wat,tsurf_lnd, tsurf_ice, & - uustar_wat, uustar_lnd, uustar_ice, weasd_lnd, weasd_ice, & - qss_wat, qss_lnd, qss_ice, ep1d_ice, gflx_ice - real(kind=kind_phys), intent(in ) :: tgice - integer, dimension(:), intent(inout) :: islmsk, islmsk_cice - real(kind=kind_phys), dimension(:), intent(inout) :: slmsk - real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice, huge - ! - real(kind=kind_phys), dimension(:), intent(inout) :: zorlo, zorll, zorli - ! - real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice - - real(kind=kind_phys) :: tem - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (frac_grid) then ! cice is ice fraction wrt water area - do i=1,im - frland(i) = landfrac(i) - if (frland(i) > zero) dry(i) = .true. - if (frland(i) < one) then - if (oceanfrac(i) > zero) then - if (cice(i) >= min_seaice) then - icy(i) = .true. - tisfc(i) = max(timin, min(tisfc(i), tgice)) - if (cplflx) then - islmsk_cice(i) = 4 - flag_cice(i) = .true. - else - islmsk_cice(i) = 2 - flag_cice(i) = .false. - endif - islmsk(i) = 2 - else - cice(i) = zero - hice(i) = zero - flag_cice(i) = .false. - islmsk_cice(i) = 0 - islmsk(i) = 0 - icy(i) = .false. - endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - else - if (cice(i) >= min_lakeice) then - icy(i) = .true. - islmsk(i) = 2 - tisfc(i) = max(timin, min(tisfc(i), tgice)) - else - cice(i) = zero - hice(i) = zero - islmsk(i) = 0 - icy(i) = .false. - endif - islmsk_cice(i) = islmsk(i) - flag_cice(i) = .false. - if (cice(i) < one) then - wet(i) = .true. ! some open lake - if (icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - endif - else ! all land - cice(i) = zero - hice(i) = zero - islmsk_cice(i) = 1 - islmsk(i) = 1 - wet(i) = .false. - icy(i) = .false. - flag_cice(i) = .false. - endif - enddo - - else - - do i = 1, IM - if (islmsk(i) == 1) then -! tsfcl(i) = tsfc(i) - dry(i) = .true. - frland(i) = one - cice(i) = zero - hice(i) = zero - icy(i) = .false. - else - frland(i) = zero - if (oceanfrac(i) > zero) then - if (cice(i) >= min_seaice) then - icy(i) = .true. - tisfc(i) = max(timin, min(tisfc(i), tgice)) - ! This cplice namelist option was added to deal with the - ! situation of the FV3ATM-HYCOM coupling without an active sea - ! ice (e.g., CICE6) component. By default, the cplice is true - ! when cplflx is .true. (e.g., for the S2S application). - ! Whereas, for the HAFS FV3ATM-HYCOM coupling, cplice is set as - ! .false.. In the future HAFS FV3ATM-MOM6 coupling, the cplflx - ! could be .true., while cplice being .false.. - if (cplice .and. cplflx) then - islmsk_cice(i) = 4 - flag_cice(i) = .true. - else - islmsk_cice(i) = 2 - flag_cice(i) = .false. - endif - islmsk(i) = 2 - else - cice(i) = zero - hice(i) = zero - flag_cice(i) = .false. - islmsk(i) = 0 - islmsk_cice(i) = 0 - icy(i) = .false. - endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean - if (cplice) then - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) - else - if (icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - endif - else - if (cice(i) >= min_lakeice) then - icy(i) = .true. - tisfc(i) = max(timin, min(tisfc(i), tgice)) - islmsk(i) = 2 - else - cice(i) = zero - hice(i) = zero - islmsk(i) = 0 - icy(i) = .false. - endif - islmsk_cice(i) = islmsk(i) - flag_cice(i) = .false. - if (cice(i) < one) then - wet(i) = .true. ! some open lake - if (icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - endif - endif - enddo - endif - - do i=1,im - tprcp_wat(i) = tprcp(i) - tprcp_lnd(i) = tprcp(i) - tprcp_ice(i) = tprcp(i) - if (wet(i)) then ! Water - uustar_wat(i) = uustar(i) - tsfc_wat(i) = tsfco(i) - tsurf_wat(i) = tsfco(i) - zorlo(i) = max(1.0e-5, min(one, zorlo(i))) - ! DH* - else - zorlo(i) = huge - ! *DH - endif - if (dry(i)) then ! Land - uustar_lnd(i) = uustar(i) - weasd_lnd(i) = weasd(i) - tsurf_lnd(i) = tsfcl(i) - ! DH* - else - zorll(i) = huge - ! *DH - !mjz - tsfcl(i) = huge - endif - if (icy(i)) then ! Ice - uustar_ice(i) = uustar(i) - weasd_ice(i) = weasd(i) - tsurf_ice(i) = tisfc(i) - ep1d_ice(i) = zero - gflx_ice(i) = zero - zorli(i) = max(1.0e-5, min(one, zorli(i))) - ! DH* - else - zorli(i) = huge - ! *DH - endif - if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) - enddo - -! to prepare to separate lake from ocean under water category - do i = 1, im - if ((wet(i) .or. icy(i)) .and. lakefrac(i) > zero) then - lake(i) = .true. - if (lkm == 1 .and. lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then - use_flake(i) = .true. - else - use_flake(i) = .false. - endif - else - lake(i) = .false. - use_flake(i) = .false. - endif - enddo -! - if (frac_grid) then - do i=1,im - if (dry(i)) then - if (icy(i)) then - if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then - tem = one / (cice(i)*(one-frland(i))) - snowd_ice(i) = max(zero, (snowd(i) - snowd_lnd(i)*frland(i)) * tem) - weasd_ice(i) = max(zero, (weasd(i) - weasd_lnd(i)*frland(i)) * tem) - endif - endif - elseif (icy(i)) then - if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then - tem = one / cice(i) - snowd_lnd(i) = zero - snowd_ice(i) = snowd(i) * tem - weasd_lnd(i) = zero - weasd_ice(i) = weasd(i) * tem - endif - endif - enddo - else - do i=1,im - if (icy(i)) then - if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then - snowd_lnd(i) = zero - weasd_lnd(i) = zero - tem = one / cice(i) - snowd_ice(i) = snowd(i) * tem - weasd_ice(i) = weasd(i) * tem - endif - endif - enddo - endif - -! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) - - end subroutine GFS_surface_composites_pre_run - -end module GFS_surface_composites_pre - - -module GFS_surface_composites_inter - - use machine, only: kind_phys - - implicit none - - private - - public GFS_surface_composites_inter_init, GFS_surface_composites_inter_finalize, GFS_surface_composites_inter_run - -contains - - subroutine GFS_surface_composites_inter_init () - end subroutine GFS_surface_composites_inter_init - - subroutine GFS_surface_composites_inter_finalize() - end subroutine GFS_surface_composites_inter_finalize - -!> \section arg_table_GFS_surface_composites_inter_run Argument Table -!! \htmlinclude GFS_surface_composites_inter_run.html -!! - subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, & - adjsfcdlw, gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat,& - adjsfcusw, adjsfcdsw, adjsfcnsw, errmsg, errflg) - - implicit none - - ! Interface variables - integer, intent(in ) :: im - logical, dimension(:), intent(in ) :: dry, icy, wet - real(kind=kind_phys), dimension(:), intent(in ) :: semis_wat, semis_lnd, semis_ice, & - adjsfcdlw, adjsfcdsw, adjsfcnsw - real(kind=kind_phys), dimension(:), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat - real(kind=kind_phys), dimension(:), intent(out) :: adjsfcusw - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! --- convert lw fluxes for land/ocean/sea-ice models - requires dcyc2t3 to set adjsfcdlw - ! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. - ! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. - ! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. - ! one needs to be aware that that the absorbed downward lw flux (used by land/ocean - ! models as downward flux) is not the same as adjsfcdlw but a value reduced by - ! the factor of emissivity. however, the net effects are the same when seeing - ! it either above the surface interface or below. - ! - ! - flux above the interface used by atmosphere model: - ! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw - ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) - ! - flux below the interface used by lnd/oc/ice models: - ! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 - ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) - ! surface upwelling shortwave flux at current time is in adjsfcusw - - ! --- ... define the downward lw flux absorbed by ground - do i=1,im - if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) - if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) - if (wet(i)) gabsbdlw_wat(i) = semis_wat(i) * adjsfcdlw(i) - adjsfcusw(i) = adjsfcdsw(i) - adjsfcnsw(i) - enddo - - end subroutine GFS_surface_composites_inter_run - -end module GFS_surface_composites_inter - - module GFS_surface_composites_post use machine, only: kind_phys @@ -386,19 +12,13 @@ module GFS_surface_composites_post private - public GFS_surface_composites_post_init, GFS_surface_composites_post_finalize, GFS_surface_composites_post_run + public GFS_surface_composites_post_run real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, & half = 0.5_kind_phys, qmin = 1.0e-8_kind_phys contains - subroutine GFS_surface_composites_post_init () - end subroutine GFS_surface_composites_post_init - - subroutine GFS_surface_composites_post_finalize() - end subroutine GFS_surface_composites_post_finalize - !> \section arg_table_GFS_surface_composites_post_run Argument Table !! \htmlinclude GFS_surface_composites_post_run.html !! diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites_post.meta similarity index 63% rename from physics/GFS_surface_composites.meta rename to physics/GFS_surface_composites_post.meta index 89048e487..c7e8c6476 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites_post.meta @@ -1,630 +1,8 @@ -[ccpp-table-properties] - name = GFS_surface_composites_pre - type = scheme - dependencies = machine.F,sfc_diff.f - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_composites_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[flag_init] - standard_name = flag_for_first_timestep - long_name = flag signaling first time step for time integration loop - units = flag - dimensions = () - type = logical - intent = in -[flag_restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart - units = flag - dimensions = () - type = logical - intent = in -[lkm] - standard_name = control_for_lake_surface_scheme - long_name = flag for lake surface model - units = flag - dimensions = () - type = integer - intent = in -[frac_grid] - standard_name = flag_for_fractional_landmask - long_name = flag for fractional grid - units = flag - dimensions = () - type = logical - intent = in -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[cplflx] - standard_name = flag_for_surface_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[cplice] - standard_name = flag_for_sea_ice_coupling - long_name = flag controlling cplice collection (default on) - units = flag - dimensions = () - type = logical - intent = in -[cplwav2atm] - standard_name = flag_for_one_way_ocean_wave_coupling_to_atmosphere - long_name = flag controlling ocean wave coupling to the atmosphere (default off) - units = flag - dimensions = () - type = logical - intent = in -[landfrac] - standard_name = land_area_fraction - long_name = fraction of horizontal grid area occupied by land - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lakefrac] - standard_name = lake_area_fraction - long_name = fraction of horizontal grid area occupied by lake - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lakedepth] - standard_name = lake_depth - long_name = lake depth - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[oceanfrac] - standard_name = sea_area_fraction - long_name = fraction of horizontal grid area occupied by ocean - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[frland] - standard_name = land_area_fraction_for_microphysics - long_name = land area fraction used in microphysics schemes - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[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 = inout -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[lake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[hice] - standard_name = sea_ice_thickness - long_name = sea ice thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[cice] - standard_name = sea_ice_area_fraction_of_sea_area_fraction - long_name = ice fraction over open water - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[zorlo] - standard_name = surface_roughness_length_over_water - long_name = surface roughness length over water - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[zorll] - standard_name = surface_roughness_length_over_land - long_name = surface roughness length over land - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[zorli] - standard_name = surface_roughness_length_over_ice - long_name = surface roughness length over ice - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[snowd] - standard_name = lwe_surface_snow - long_name = water equivalent snow depth - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[snowd_lnd] - standard_name = surface_snow_thickness_water_equivalent_over_land - long_name = water equivalent snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[snowd_ice] - standard_name = surface_snow_thickness_water_equivalent_over_ice - long_name = water equivalent snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tprcp] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep - long_name = total precipitation amount in each time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tprcp_wat] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_water - long_name = total precipitation amount in each time step over water - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tprcp_lnd] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land - long_name = total precipitation amount in each time step over land - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tprcp_ice] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice - long_name = total precipitation amount in each time step over ice - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[uustar] - standard_name = surface_friction_velocity - long_name = boundary layer parameter - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[uustar_wat] - standard_name = surface_friction_velocity_over_water - long_name = surface friction velocity over water - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[uustar_lnd] - standard_name = surface_friction_velocity_over_land - long_name = surface friction velocity over land - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[uustar_ice] - standard_name = surface_friction_velocity_over_ice - long_name = surface friction velocity over ice - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[weasd] - standard_name = lwe_thickness_of_surface_snow_amount - long_name = water equiv of acc snow depth over land and sea ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[weasd_lnd] - standard_name = water_equivalent_accumulated_snow_depth_over_land - long_name = water equiv of acc snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[weasd_ice] - standard_name = water_equivalent_accumulated_snow_depth_over_ice - long_name = water equiv of acc snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[ep1d_ice] - standard_name = surface_upward_potential_latent_heat_flux_over_ice - long_name = surface upward potential latent heat flux over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsfco] - standard_name = sea_surface_temperature - long_name = sea surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsfcl] - standard_name = surface_skin_temperature_over_land - long_name = surface skin temperature over land - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsfc_wat] - standard_name = surface_skin_temperature_over_water - long_name = surface skin temperature over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tisfc] - standard_name = surface_skin_temperature_over_ice - long_name = surface skin temperature over ice - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsurf_wat] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsurf_lnd] - standard_name = surface_skin_temperature_after_iteration_over_land - long_name = surface skin temperature after iteration over land - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsurf_ice] - standard_name = surface_skin_temperature_after_iteration_over_ice - long_name = surface skin temperature after iteration over ice - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[gflx_ice] - standard_name = upward_heat_flux_in_soil_over_ice - long_name = soil heat flux over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tgice] - standard_name = freezing_point_temperature_of_seawater - long_name = freezing point temperature of seawater - units = K - dimensions = () - type = real - kind = kind_phys - intent = in -[islmsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[islmsk_cice] - standard_name = sea_land_ice_mask_cice - long_name = sea/land/ice mask cice (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[slmsk] - standard_name = area_type - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[qss] - standard_name = surface_specific_humidity - long_name = surface air saturation specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[qss_wat] - standard_name = surface_specific_humidity_over_water - long_name = surface air saturation specific humidity over water - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[qss_lnd] - 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 -[qss_ice] - standard_name = surface_specific_humidity_over_ice - long_name = surface air saturation specific humidity over ice - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[min_lakeice] - standard_name = min_lake_ice_area_fraction - long_name = minimum lake ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[min_seaice] - standard_name = min_sea_ice_area_fraction - long_name = minimum sea ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[kdt] - standard_name = index_of_timestep - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in -[huge] - standard_name = netcdf_float_fillvalue - long_name = definition of NetCDF float FillValue - units = none - dimensions = () - type = real - kind = kind_phys - 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-table-properties] - name = GFS_surface_composites_inter - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_composites_inter_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - 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 -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[semis_wat] - standard_name = surface_longwave_emissivity_over_water - long_name = surface lw emissivity in fraction over water - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[semis_lnd] - standard_name = surface_longwave_emissivity_over_land - long_name = surface lw emissivity in fraction over land - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[semis_ice] - standard_name = surface_longwave_emissivity_over_ice - long_name = surface lw emissivity in fraction over ice - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfcdlw] - standard_name = surface_downwelling_longwave_flux - long_name = surface downwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[gabsbdlw_lnd] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land - long_name = total sky surface downward longwave flux absorbed by the ground over land - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[gabsbdlw_ice] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ice - long_name = total sky surface downward longwave flux absorbed by the ground over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[gabsbdlw_wat] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_water - long_name = total sky surface downward longwave flux absorbed by the ground over water - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[adjsfcusw] - standard_name = surface_upwelling_shortwave_flux - long_name = surface upwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[adjsfcdsw] - standard_name = surface_downwelling_shortwave_flux - long_name = surface downwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfcnsw] - standard_name = surface_net_downwelling_shortwave_flux - long_name = surface net downwelling shortwave flux at current time - units = W m-2 - 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 - 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-table-properties] name = GFS_surface_composites_post type = scheme - dependencies = machine.F + dependencies = machine.F,sfc_diff.f ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 new file mode 100644 index 000000000..76dd6d325 --- /dev/null +++ b/physics/GFS_surface_composites_pre.F90 @@ -0,0 +1,293 @@ +!> \file GFS_surface_composites_pre.F90 +!! Contains code related to generating composites for all GFS surface schemes. + +module GFS_surface_composites_pre + + use machine, only: kind_phys + use physparam, only : iemsflg + + implicit none + + private + + public GFS_surface_composites_pre_run + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys + +! real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue + +contains + +!> \section arg_table_GFS_surface_composites_pre_run Argument Table +!! \htmlinclude GFS_surface_composites_pre_run.html +!! + subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, frac_grid, & + flag_cice, cplflx, cplice, cplwav2atm, landfrac, lakefrac, lakedepth, oceanfrac, frland, & + dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & + snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & + weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & + tisfc, tsurf_wat, tsurf_lnd, tsurf_ice, & + gflx_ice, tgice, islmsk, islmsk_cice, slmsk, qss, qss_wat, qss_lnd, qss_ice, & + min_lakeice, min_seaice, kdt, huge, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in ) :: im, lkm, kdt + logical, intent(in ) :: flag_init, flag_restart, frac_grid, cplflx, cplice, cplwav2atm + logical, dimension(:), intent(inout) :: flag_cice + logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet + real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac + real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice + real(kind=kind_phys), dimension(:), intent( out) :: frland + real(kind=kind_phys), dimension(:), intent(in ) :: snowd, tprcp, uustar, weasd, qss + + real(kind=kind_phys), dimension(:), intent(inout) :: tsfc, tsfco, tsfcl, tisfc + real(kind=kind_phys), dimension(:), intent(inout) :: snowd_lnd, snowd_ice, tprcp_wat, & + tprcp_lnd, tprcp_ice, tsfc_wat, tsurf_wat,tsurf_lnd, tsurf_ice, & + uustar_wat, uustar_lnd, uustar_ice, weasd_lnd, weasd_ice, & + qss_wat, qss_lnd, qss_ice, ep1d_ice, gflx_ice + real(kind=kind_phys), intent(in ) :: tgice + integer, dimension(:), intent(inout) :: islmsk, islmsk_cice + real(kind=kind_phys), dimension(:), intent(inout) :: slmsk + real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice, huge + ! + real(kind=kind_phys), dimension(:), intent(inout) :: zorlo, zorll, zorli + ! + real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice + + real(kind=kind_phys) :: tem + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (frac_grid) then ! cice is ice fraction wrt water area + do i=1,im + frland(i) = landfrac(i) + if (frland(i) > zero) dry(i) = .true. + if (frland(i) < one) then + if (oceanfrac(i) > zero) then + if (cice(i) >= min_seaice) then + icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) + if (cplflx) then + islmsk_cice(i) = 4 + flag_cice(i) = .true. + else + islmsk_cice(i) = 2 + flag_cice(i) = .false. + endif + islmsk(i) = 2 + else + cice(i) = zero + hice(i) = zero + flag_cice(i) = .false. + islmsk_cice(i) = 0 + islmsk(i) = 0 + icy(i) = .false. + endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + else + if (cice(i) >= min_lakeice) then + icy(i) = .true. + islmsk(i) = 2 + tisfc(i) = max(timin, min(tisfc(i), tgice)) + else + cice(i) = zero + hice(i) = zero + islmsk(i) = 0 + icy(i) = .false. + endif + islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. + if (cice(i) < one) then + wet(i) = .true. ! some open lake + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + endif + else ! all land + cice(i) = zero + hice(i) = zero + islmsk_cice(i) = 1 + islmsk(i) = 1 + wet(i) = .false. + icy(i) = .false. + flag_cice(i) = .false. + endif + enddo + + else + + do i = 1, IM + if (islmsk(i) == 1) then +! tsfcl(i) = tsfc(i) + dry(i) = .true. + frland(i) = one + cice(i) = zero + hice(i) = zero + icy(i) = .false. + else + frland(i) = zero + if (oceanfrac(i) > zero) then + if (cice(i) >= min_seaice) then + icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) + ! This cplice namelist option was added to deal with the + ! situation of the FV3ATM-HYCOM coupling without an active sea + ! ice (e.g., CICE6) component. By default, the cplice is true + ! when cplflx is .true. (e.g., for the S2S application). + ! Whereas, for the HAFS FV3ATM-HYCOM coupling, cplice is set as + ! .false.. In the future HAFS FV3ATM-MOM6 coupling, the cplflx + ! could be .true., while cplice being .false.. + if (cplice .and. cplflx) then + islmsk_cice(i) = 4 + flag_cice(i) = .true. + else + islmsk_cice(i) = 2 + flag_cice(i) = .false. + endif + islmsk(i) = 2 + else + cice(i) = zero + hice(i) = zero + flag_cice(i) = .false. + islmsk(i) = 0 + islmsk_cice(i) = 0 + icy(i) = .false. + endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + if (cplice) then + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + else + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + endif + else + if (cice(i) >= min_lakeice) then + icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) + islmsk(i) = 2 + else + cice(i) = zero + hice(i) = zero + islmsk(i) = 0 + icy(i) = .false. + endif + islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. + if (cice(i) < one) then + wet(i) = .true. ! some open lake + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + endif + endif + enddo + endif + + do i=1,im + tprcp_wat(i) = tprcp(i) + tprcp_lnd(i) = tprcp(i) + tprcp_ice(i) = tprcp(i) + if (wet(i)) then ! Water + uustar_wat(i) = uustar(i) + tsfc_wat(i) = tsfco(i) + tsurf_wat(i) = tsfco(i) + zorlo(i) = max(1.0e-5, min(one, zorlo(i))) + ! DH* + else + zorlo(i) = huge + ! *DH + endif + if (dry(i)) then ! Land + uustar_lnd(i) = uustar(i) + weasd_lnd(i) = weasd(i) + tsurf_lnd(i) = tsfcl(i) + ! DH* + else + zorll(i) = huge + ! *DH + !mjz + tsfcl(i) = huge + endif + if (icy(i)) then ! Ice + uustar_ice(i) = uustar(i) + weasd_ice(i) = weasd(i) + tsurf_ice(i) = tisfc(i) + ep1d_ice(i) = zero + gflx_ice(i) = zero + zorli(i) = max(1.0e-5, min(one, zorli(i))) + ! DH* + else + zorli(i) = huge + ! *DH + endif + if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) + enddo + +! to prepare to separate lake from ocean under water category + do i = 1, im + if ((wet(i) .or. icy(i)) .and. lakefrac(i) > zero) then + lake(i) = .true. + if (lkm == 1 .and. lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then + use_flake(i) = .true. + else + use_flake(i) = .false. + endif + else + lake(i) = .false. + use_flake(i) = .false. + endif + enddo +! + if (frac_grid) then + do i=1,im + if (dry(i)) then + if (icy(i)) then + if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then + tem = one / (cice(i)*(one-frland(i))) + snowd_ice(i) = max(zero, (snowd(i) - snowd_lnd(i)*frland(i)) * tem) + weasd_ice(i) = max(zero, (weasd(i) - weasd_lnd(i)*frland(i)) * tem) + endif + endif + elseif (icy(i)) then + if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then + tem = one / cice(i) + snowd_lnd(i) = zero + snowd_ice(i) = snowd(i) * tem + weasd_lnd(i) = zero + weasd_ice(i) = weasd(i) * tem + endif + endif + enddo + else + do i=1,im + if (icy(i)) then + if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then + snowd_lnd(i) = zero + weasd_lnd(i) = zero + tem = one / cice(i) + snowd_ice(i) = snowd(i) * tem + weasd_ice(i) = weasd(i) * tem + endif + endif + enddo + endif + +! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) + + end subroutine GFS_surface_composites_pre_run + +end module GFS_surface_composites_pre \ No newline at end of file diff --git a/physics/GFS_surface_composites_pre.meta b/physics/GFS_surface_composites_pre.meta new file mode 100644 index 000000000..dd9460b47 --- /dev/null +++ b/physics/GFS_surface_composites_pre.meta @@ -0,0 +1,487 @@ +[ccpp-table-properties] + name = GFS_surface_composites_pre + type = scheme + dependencies = machine.F,physparam.f + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_composites_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[flag_init] + standard_name = flag_for_first_timestep + long_name = flag signaling first time step for time integration loop + units = flag + dimensions = () + type = logical + intent = in +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[lkm] + standard_name = control_for_lake_surface_scheme + long_name = flag for lake surface model + units = flag + dimensions = () + type = integer + intent = in +[frac_grid] + standard_name = flag_for_fractional_landmask + long_name = flag for fractional grid + units = flag + dimensions = () + type = logical + intent = in +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[cplflx] + standard_name = flag_for_surface_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[cplice] + standard_name = flag_for_sea_ice_coupling + long_name = flag controlling cplice collection (default on) + units = flag + dimensions = () + type = logical + intent = in +[cplwav2atm] + standard_name = flag_for_one_way_ocean_wave_coupling_to_atmosphere + long_name = flag controlling ocean wave coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical + intent = in +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lakedepth] + standard_name = lake_depth + long_name = lake depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[frland] + standard_name = land_area_fraction_for_microphysics + long_name = land area fraction used in microphysics schemes + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[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 = inout +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[lake] + standard_name = flag_nonzero_lake_surface_fraction + long_name = flag indicating presence of some lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[hice] + standard_name = sea_ice_thickness + long_name = sea ice thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[cice] + standard_name = sea_ice_area_fraction_of_sea_area_fraction + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[zorlo] + standard_name = surface_roughness_length_over_water + long_name = surface roughness length over water + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[zorll] + standard_name = surface_roughness_length_over_land + long_name = surface roughness length over land + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[zorli] + standard_name = surface_roughness_length_over_ice + long_name = surface roughness length over ice + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snowd] + standard_name = lwe_surface_snow + long_name = water equivalent snow depth + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[snowd_lnd] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snowd_ice] + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tprcp] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total precipitation amount in each time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tprcp_wat] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_water + long_name = total precipitation amount in each time step over water + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tprcp_lnd] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land + long_name = total precipitation amount in each time step over land + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tprcp_ice] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice + long_name = total precipitation amount in each time step over ice + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[uustar] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[uustar_wat] + standard_name = surface_friction_velocity_over_water + long_name = surface friction velocity over water + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[uustar_lnd] + standard_name = surface_friction_velocity_over_land + long_name = surface friction velocity over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[uustar_ice] + standard_name = surface_friction_velocity_over_ice + long_name = surface friction velocity over ice + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[weasd] + standard_name = lwe_thickness_of_surface_snow_amount + long_name = water equiv of acc snow depth over land and sea ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[weasd_lnd] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equiv of acc snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[weasd_ice] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ep1d_ice] + standard_name = surface_upward_potential_latent_heat_flux_over_ice + long_name = surface upward potential latent heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfco] + standard_name = sea_surface_temperature + long_name = sea surface temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfcl] + standard_name = surface_skin_temperature_over_land + long_name = surface skin temperature over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfc_wat] + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tisfc] + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsurf_wat] + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsurf_lnd] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsurf_ice] + standard_name = surface_skin_temperature_after_iteration_over_ice + long_name = surface skin temperature after iteration over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[gflx_ice] + standard_name = upward_heat_flux_in_soil_over_ice + long_name = soil heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tgice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[islmsk_cice] + standard_name = sea_land_ice_mask_cice + long_name = sea/land/ice mask cice (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[slmsk] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[qss] + standard_name = surface_specific_humidity + long_name = surface air saturation specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[qss_wat] + standard_name = surface_specific_humidity_over_water + long_name = surface air saturation specific humidity over water + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[qss_lnd] + 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 +[qss_ice] + standard_name = surface_specific_humidity_over_ice + long_name = surface air saturation specific humidity over ice + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[min_lakeice] + standard_name = min_lake_ice_area_fraction + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[min_seaice] + standard_name = min_sea_ice_area_fraction + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[huge] + standard_name = netcdf_float_fillvalue + long_name = definition of NetCDF float FillValue + units = none + dimensions = () + type = real + kind = kind_phys + 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 \ No newline at end of file diff --git a/physics/GFS_surface_loop_control_part1.F90 b/physics/GFS_surface_loop_control_part1.F90 new file mode 100644 index 000000000..9d73608b4 --- /dev/null +++ b/physics/GFS_surface_loop_control_part1.F90 @@ -0,0 +1,51 @@ +!> \file GFS_surface_loop_control_part1.F90 +!! This file contains the GFS_surface_loop_control_part1 scheme. + +!> \defgroup GFS_surface_loop_control GFS_surface_loop_control scheme +!! @{ + + module GFS_surface_loop_control_part1 + contains + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_GFS_surface_loop_control_part1_run Arguments +!! \htmlinclude GFS_surface_loop_control_part1_run.html +!! +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + + subroutine GFS_surface_loop_control_part1_run (im, iter, & + wind, flag_guess, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im + integer, intent(in) :: iter + real(kind=kind_phys), dimension(:), intent(in) :: wind + logical, dimension(:), intent(inout) :: flag_guess + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i=1,im + if (iter == 1 .and. wind(i) < 2.0d0) then + flag_guess(i) = .true. + endif + enddo + + end subroutine GFS_surface_loop_control_part1_run +!> @} + end module GFS_surface_loop_control_part1 +!> @} \ No newline at end of file diff --git a/physics/GFS_surface_loop_control_part1.meta b/physics/GFS_surface_loop_control_part1.meta new file mode 100644 index 000000000..f178320ee --- /dev/null +++ b/physics/GFS_surface_loop_control_part1.meta @@ -0,0 +1,53 @@ +[ccpp-table-properties] + name = GFS_surface_loop_control_part1 + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_loop_control_part1_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[iter] + standard_name = ccpp_loop_counter + long_name = loop counter for subcycling loops in CCPP + units = index + dimensions = () + type = integer + intent = in +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[flag_guess] + standard_name = flag_for_guess_run + long_name = flag for guess run + units = flag + dimensions = (horizontal_loop_extent) + type = logical + 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 \ No newline at end of file diff --git a/physics/GFS_surface_loop_control.F90 b/physics/GFS_surface_loop_control_part2.F90 similarity index 51% rename from physics/GFS_surface_loop_control.F90 rename to physics/GFS_surface_loop_control_part2.F90 index 0de1c8ee5..80b25ca1e 100644 --- a/physics/GFS_surface_loop_control.F90 +++ b/physics/GFS_surface_loop_control_part2.F90 @@ -1,60 +1,5 @@ -!> \file GFS_surface_loop_control.F90 -!! This file contains the GFS_surface_loop_control scheme. - -!> \defgroup GFS_surface_loop_control GFS_surface_loop_control scheme -!! @{ - - module GFS_surface_loop_control_part1 - contains - - subroutine GFS_surface_loop_control_part1_init - end subroutine GFS_surface_loop_control_part1_init - - subroutine GFS_surface_loop_control_part1_finalize - end subroutine GFS_surface_loop_control_part1_finalize - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_GFS_surface_loop_control_part1_run Arguments -!! \htmlinclude GFS_surface_loop_control_part1_run.html -!! -!! \section general General Algorithm -!! \section detailed Detailed Algorithm -!! @{ - - subroutine GFS_surface_loop_control_part1_run (im, iter, & - wind, flag_guess, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in) :: im - integer, intent(in) :: iter - real(kind=kind_phys), dimension(:), intent(in) :: wind - logical, dimension(:), intent(inout) :: flag_guess - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i=1,im - if (iter == 1 .and. wind(i) < 2.0d0) then - flag_guess(i) = .true. - endif - enddo - - end subroutine GFS_surface_loop_control_part1_run -!> @} - end module GFS_surface_loop_control_part1 -!> @} +!> \file GFS_surface_loop_control_part2.F90 +!! This file contains the GFS_surface_loop_control_part2 scheme. !> \defgroup GFS_surface_loop_control GFS_surface_loop_control scheme !! @{ @@ -62,12 +7,6 @@ end module GFS_surface_loop_control_part1 module GFS_surface_loop_control_part2 contains - subroutine GFS_surface_loop_control_part2_init - end subroutine GFS_surface_loop_control_part2_init - - subroutine GFS_surface_loop_control_part2_finalize - end subroutine GFS_surface_loop_control_part2_finalize - !> \brief Brief description of the subroutine !! #if 0 diff --git a/physics/GFS_surface_loop_control.meta b/physics/GFS_surface_loop_control_part2.meta similarity index 67% rename from physics/GFS_surface_loop_control.meta rename to physics/GFS_surface_loop_control_part2.meta index 4a522ff43..7c9bc7408 100644 --- a/physics/GFS_surface_loop_control.meta +++ b/physics/GFS_surface_loop_control_part2.meta @@ -1,57 +1,3 @@ -[ccpp-table-properties] - name = GFS_surface_loop_control_part1 - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_loop_control_part1_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[iter] - standard_name = ccpp_loop_counter - long_name = loop counter for subcycling loops in CCPP - units = index - dimensions = () - type = integer - intent = in -[wind] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[flag_guess] - standard_name = flag_for_guess_run - long_name = flag for guess run - units = flag - dimensions = (horizontal_loop_extent) - type = logical - 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 - ######################################################################## [ccpp-table-properties] name = GFS_surface_loop_control_part2 diff --git a/physics/cs_conv.F90 b/physics/cs_conv.F90 index 8ed33f0d3..ebadf5b34 100644 --- a/physics/cs_conv.F90 +++ b/physics/cs_conv.F90 @@ -1,124 +1,6 @@ !> \file cs_conv.F90 !! This file contains the Chikira-Sugiyama Convection scheme. -module cs_conv_pre - contains - - subroutine cs_conv_pre_init() - end subroutine cs_conv_pre_init - - subroutine cs_conv_pre_finalize() - end subroutine cs_conv_pre_finalize - -!! \section arg_table_cs_conv_pre_run Argument Table -!! \htmlinclude cs_conv_pre_run.html -!! - subroutine cs_conv_pre_run(im, levs, ntrac, q, clw1, clw2, & - & work1, work2, cs_parm1, cs_parm2, wcbmax, & - & fswtr, fscav, save_q1, save_q2, save_q3, & - & errmsg, errflg) - - - use machine , only : kind_phys - - implicit none - -! --- inputs - integer, intent(in) :: im, levs, ntrac - real(kind_phys), dimension(:,:), intent(in) :: q - real(kind_phys), dimension(:,:), intent(in) :: clw1,clw2 - real(kind_phys), dimension(:), intent(in) :: work1, work2 - real(kind_phys), intent(in) :: cs_parm1, cs_parm2 - -! --- input/output - real(kind_phys), dimension(:), intent(out) :: fswtr, fscav - real(kind_phys), dimension(:), intent(out) :: wcbmax - real(kind_phys), dimension(:,:), intent(out) :: save_q1,save_q2 - ! save_q3 is not allocated for Zhao-Carr MP - real(kind_phys), dimension(:,:), intent(out) :: save_q3 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals - integer :: i, k - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i =1,im - wcbmax(i) = cs_parm1 * work1(i) + cs_parm2 * work2(i) - enddo - - fswtr(:) = 0.0 - fscav(:) = 0.0 - do k=1,levs - do i=1,im - ! DH* note - save_q1 assignment may be redundant, - ! because already done in GFS_DCNV_generic_pre? - ! Keep for using cs_conv w/o GFS_DCNV_generic_pre? - save_q1(i,k) = q(i,k) - save_q2(i,k) = max(0.0,clw2(i,k)) - save_q3(i,k) = max(0.0,clw1(i,k)) - enddo - enddo - - return - end subroutine cs_conv_pre_run - -end module cs_conv_pre - -module cs_conv_post - contains - - subroutine cs_conv_post_init() - end subroutine cs_conv_post_init - - subroutine cs_conv_post_finalize() - end subroutine cs_conv_post_finalize - -!> \section arg_table_cs_conv_post_run Argument Table -!! \htmlinclude cs_conv_post_run.html -!! - subroutine cs_conv_post_run(im, kmax, do_aw, sigmatot, sigmafrac, errmsg, errflg) - - use machine , only : kind_phys - - implicit none - -! --- inputs - integer, intent(in) :: im, kmax - logical, intent(in) :: do_aw - real(kind_phys), dimension(:,:), intent(in) :: sigmatot - -! --- input/output - real(kind_phys), dimension(:,:), intent(out) :: sigmafrac - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals - integer :: i, k, kk - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (do_aw) then - do k=1,kmax - kk = min(k+1,kmax) ! assuming no cloud top reaches the model top - do i=1,im !DD - sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) - enddo - enddo - endif - - return - end subroutine cs_conv_post_run - -end module cs_conv_post - module cs_conv !--------------------------------------------------------------------------------- ! Purpose: diff --git a/physics/cs_conv.meta b/physics/cs_conv.meta index 90a411031..fae1c91fe 100644 --- a/physics/cs_conv.meta +++ b/physics/cs_conv.meta @@ -1,216 +1,3 @@ -[ccpp-table-properties] - name = cs_conv_pre - type = scheme - dependencies = funcphys.f90,machine.F,physcons.F90 - -######################################################################## -[ccpp-arg-table] - name = cs_conv_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of veritcal levels - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[q] - standard_name = specific_humidity_of_new_state - long_name = water vapor specific humidity updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[clw1] - standard_name = ice_water_mixing_ratio_convective_transport_tracer - long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[clw2] - standard_name = cloud_condensed_water_mixing_ratio_convective_transport_tracer - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[cs_parm1] - standard_name = updraft_velocity_tunable_parameter_1_CS - long_name = tunable parameter 1 for Chikira-Sugiyama convection - units = m s-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[cs_parm2] - standard_name = updraft_velocity_tunable_parameter_2_CS - long_name = tunable parameter 2 for Chikira-Sugiyama convection - units = m s-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[wcbmax] - standard_name = maximum_updraft_velocity_at_cloud_base - long_name = maximum updraft velocity at cloud base - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[fswtr] - standard_name = fraction_of_cloud_top_water_scavenged - long_name = fraction of the tracer (cloud top water) that is scavenged by convection - units = km-1 - dimensions = (number_of_tracers_scavenged) - type = real - kind = kind_phys - intent = out -[fscav] - standard_name = fraction_of_tracer_scavenged - long_name = fraction of the tracer (aerosols) that is scavenged by convection - units = km-1 - dimensions = (number_of_tracers_scavenged) - type = real - kind = kind_phys - intent = out -[save_q1] - standard_name = water_vapor_specific_humidity_save - long_name = water vapor specific humidity before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[save_q2] - standard_name = cloud_condensed_water_mixing_ratio_save - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[save_q3] - standard_name = ice_water_mixing_ratio_save - long_name = cloud ice water mixing ratio before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - 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-table-properties] - name = cs_conv_post - type = scheme - dependencies = funcphys.f90,machine.F,physcons.F90 - -######################################################################## -[ccpp-arg-table] - name = cs_conv_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[kmax] - standard_name = vertical_layer_dimension - long_name = number of veritcal levels - units = count - dimensions = () - type = integer - intent = in -[do_aw] - standard_name = flag_for_Arakawa_Wu_adjustment - long_name = flag for Arakawa Wu scale-aware adjustment - units = flag - dimensions = () - type = logical - intent = in -[sigmatot] - standard_name = convective_updraft_area_fraction_at_model_interfaces - long_name = convective updraft area fraction at model interfaces - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[sigmafrac] - standard_name = convective_updraft_area_fraction - long_name = convective updraft area fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - 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-table-properties] name = cs_conv diff --git a/physics/cs_conv_post.F90 b/physics/cs_conv_post.F90 new file mode 100644 index 000000000..403b4d204 --- /dev/null +++ b/physics/cs_conv_post.F90 @@ -0,0 +1,46 @@ +!> \file cs_conv_post.F90 +!! This file contains code to execute after the Chikira-Sugiyama Convection scheme. + +module cs_conv_post + contains + +!> \section arg_table_cs_conv_post_run Argument Table +!! \htmlinclude cs_conv_post_run.html +!! + subroutine cs_conv_post_run(im, kmax, do_aw, sigmatot, sigmafrac, errmsg, errflg) + + use machine , only : kind_phys + + implicit none + +! --- inputs + integer, intent(in) :: im, kmax + logical, intent(in) :: do_aw + real(kind_phys), dimension(:,:), intent(in) :: sigmatot + +! --- input/output + real(kind_phys), dimension(:,:), intent(out) :: sigmafrac + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! --- locals + integer :: i, k, kk + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (do_aw) then + do k=1,kmax + kk = min(k+1,kmax) ! assuming no cloud top reaches the model top + do i=1,im !DD + sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) + enddo + enddo + endif + + return + end subroutine cs_conv_post_run + +end module cs_conv_post \ No newline at end of file diff --git a/physics/cs_conv_post.meta b/physics/cs_conv_post.meta new file mode 100644 index 000000000..116ffbef4 --- /dev/null +++ b/physics/cs_conv_post.meta @@ -0,0 +1,62 @@ +######################################################################## +[ccpp-table-properties] + name = cs_conv_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = cs_conv_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[kmax] + standard_name = vertical_layer_dimension + long_name = number of veritcal levels + units = count + dimensions = () + type = integer + intent = in +[do_aw] + standard_name = flag_for_Arakawa_Wu_adjustment + long_name = flag for Arakawa Wu scale-aware adjustment + units = flag + dimensions = () + type = logical + intent = in +[sigmatot] + standard_name = convective_updraft_area_fraction_at_model_interfaces + long_name = convective updraft area fraction at model interfaces + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sigmafrac] + standard_name = convective_updraft_area_fraction + long_name = convective updraft area fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + 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 \ No newline at end of file diff --git a/physics/cs_conv_pre.F90 b/physics/cs_conv_pre.F90 new file mode 100644 index 000000000..8cc1020d4 --- /dev/null +++ b/physics/cs_conv_pre.F90 @@ -0,0 +1,64 @@ +!> \file cs_conv_pre.F90 +!! This file contains preparation for the Chikira-Sugiyama Convection scheme. + +module cs_conv_pre + contains + +!! \section arg_table_cs_conv_pre_run Argument Table +!! \htmlinclude cs_conv_pre_run.html +!! + subroutine cs_conv_pre_run(im, levs, ntrac, q, clw1, clw2, & + & work1, work2, cs_parm1, cs_parm2, wcbmax, & + & fswtr, fscav, save_q1, save_q2, save_q3, & + & errmsg, errflg) + + + use machine , only : kind_phys + + implicit none + +! --- inputs + integer, intent(in) :: im, levs, ntrac + real(kind_phys), dimension(:,:), intent(in) :: q + real(kind_phys), dimension(:,:), intent(in) :: clw1,clw2 + real(kind_phys), dimension(:), intent(in) :: work1, work2 + real(kind_phys), intent(in) :: cs_parm1, cs_parm2 + +! --- input/output + real(kind_phys), dimension(:), intent(out) :: fswtr, fscav + real(kind_phys), dimension(:), intent(out) :: wcbmax + real(kind_phys), dimension(:,:), intent(out) :: save_q1,save_q2 + ! save_q3 is not allocated for Zhao-Carr MP + real(kind_phys), dimension(:,:), intent(out) :: save_q3 + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! --- locals + integer :: i, k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i =1,im + wcbmax(i) = cs_parm1 * work1(i) + cs_parm2 * work2(i) + enddo + + fswtr(:) = 0.0 + fscav(:) = 0.0 + do k=1,levs + do i=1,im + ! DH* note - save_q1 assignment may be redundant, + ! because already done in GFS_DCNV_generic_pre? + ! Keep for using cs_conv w/o GFS_DCNV_generic_pre? + save_q1(i,k) = q(i,k) + save_q2(i,k) = max(0.0,clw2(i,k)) + save_q3(i,k) = max(0.0,clw1(i,k)) + enddo + enddo + + return + end subroutine cs_conv_pre_run + +end module cs_conv_pre \ No newline at end of file diff --git a/physics/cs_conv_pre.meta b/physics/cs_conv_pre.meta new file mode 100644 index 000000000..2decd5f8b --- /dev/null +++ b/physics/cs_conv_pre.meta @@ -0,0 +1,149 @@ +[ccpp-table-properties] + name = cs_conv_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = cs_conv_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = number of veritcal levels + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[q] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[clw1] + standard_name = ice_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[clw2] + standard_name = cloud_condensed_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cs_parm1] + standard_name = updraft_velocity_tunable_parameter_1_CS + long_name = tunable parameter 1 for Chikira-Sugiyama convection + units = m s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[cs_parm2] + standard_name = updraft_velocity_tunable_parameter_2_CS + long_name = tunable parameter 2 for Chikira-Sugiyama convection + units = m s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[wcbmax] + standard_name = maximum_updraft_velocity_at_cloud_base + long_name = maximum updraft velocity at cloud base + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[fswtr] + standard_name = fraction_of_cloud_top_water_scavenged + long_name = fraction of the tracer (cloud top water) that is scavenged by convection + units = km-1 + dimensions = (number_of_tracers_scavenged) + type = real + kind = kind_phys + intent = out +[fscav] + standard_name = fraction_of_tracer_scavenged + long_name = fraction of the tracer (aerosols) that is scavenged by convection + units = km-1 + dimensions = (number_of_tracers_scavenged) + type = real + kind = kind_phys + intent = out +[save_q1] + standard_name = water_vapor_specific_humidity_save + long_name = water vapor specific humidity before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[save_q2] + standard_name = cloud_condensed_water_mixing_ratio_save + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[save_q3] + standard_name = ice_water_mixing_ratio_save + long_name = cloud ice water mixing ratio before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + 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 \ No newline at end of file diff --git a/physics/get_phi_fv3.F90 b/physics/get_phi_fv3.F90 new file mode 100644 index 000000000..157a29f56 --- /dev/null +++ b/physics/get_phi_fv3.F90 @@ -0,0 +1,56 @@ +module get_phi_fv3 + + use machine, only: kind_phys + use physcons, only: con_fvirt + +!--- public declarations + public get_phi_fv3_run + +!--- local variables + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: half = 0.5_kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + +contains + +!! \section arg_table_get_phi_fv3_run Argument Table +!! \htmlinclude get_phi_fv3_run.html +!! + subroutine get_phi_fv3_run(ix, levs, con_fvirt, gt0, gq01, del_gz, phii, phil, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in) :: ix, levs + real(kind=kind_phys), intent(in) :: con_fvirt + real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 + real(kind=kind_phys), dimension(:,:), intent(in) :: gq01 + real(kind=kind_phys), dimension(:,:), intent(inout) :: del_gz + real(kind=kind_phys), dimension(:,:), intent(out) :: phii + real(kind=kind_phys), dimension(:,:), intent(out) :: phil + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i, k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +! SJL: Adjust the height hydrostatically in a way consistent with FV3 discretization + do i=1,ix + phii(i,1) = zero + enddo + do k=1,levs + do i=1,ix + del_gz(i,k) = del_gz(i,k)*gt0(i,k) * & + & (one + con_fvirt*max(zero,gq01(i,k))) + phii(i,k+1) = phii(i,k) + del_gz(i,k) + phil(i,k) = half*(phii(i,k) + phii(i,k+1)) + enddo + enddo + + end subroutine get_phi_fv3_run + +end module get_phi_fv3 \ No newline at end of file diff --git a/physics/get_phi_fv3.meta b/physics/get_phi_fv3.meta new file mode 100644 index 000000000..cbca14080 --- /dev/null +++ b/physics/get_phi_fv3.meta @@ -0,0 +1,87 @@ +######################################################################## +[ccpp-table-properties] + name = get_phi_fv3 + type = scheme + dependencies = machine.F,physcons.F90 + +######################################################################## +[ccpp-arg-table] + name = get_phi_fv3_run + type = scheme +[ix] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical layers + units = count + dimensions = () + type = integer + intent = in +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = updated air temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq01] + standard_name = specific_humidity_of_new_state + long_name = mid-layer specific humidity of water vapor + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[del_gz] + standard_name = geopotential_difference_between_midlayers_divided_by_midlayer_virtual_temperature + long_name = difference between mid-layer geopotentials divided by mid-layer virtual temperature + units = m2 s-2 K-1 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[phii] + standard_name = geopotential_at_interface + long_name = interface geopotential + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = out +[phil] + standard_name = geopotential + long_name = mid-layer geopotential + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + 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 \ No newline at end of file diff --git a/physics/get_prs_fv3.F90 b/physics/get_prs_fv3.F90 index 35bdc35ca..bff48a97d 100644 --- a/physics/get_prs_fv3.F90 +++ b/physics/get_prs_fv3.F90 @@ -1,10 +1,9 @@ module get_prs_fv3 use machine, only: kind_phys -! use physcons, only: con_fvirt !--- public declarations - public get_prs_fv3_init, get_prs_fv3_run, get_prs_fv3_finalize + public get_prs_fv3_run !--- local variables real(kind=kind_phys), parameter :: zero = 0.0_kind_phys @@ -12,9 +11,6 @@ module get_prs_fv3 contains - subroutine get_prs_fv3_init() - end subroutine get_prs_fv3_init - !! \section arg_table_get_prs_fv3_run Argument Table !! \htmlinclude get_prs_fv3_run.html !! @@ -53,73 +49,4 @@ subroutine get_prs_fv3_run(ix, levs, con_fvirt, phii, prsi, tgrs, qgrs1, del, de end subroutine get_prs_fv3_run - subroutine get_prs_fv3_finalize() - end subroutine get_prs_fv3_finalize - -end module get_prs_fv3 - - -module get_phi_fv3 - - use machine, only: kind_phys - use physcons, only: con_fvirt - -!--- public declarations - public get_phi_fv3_init, get_phi_fv3_run, get_phi_fv3_finalize - -!--- local variables - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys - real(kind=kind_phys), parameter :: half = 0.5_kind_phys - real(kind=kind_phys), parameter :: one = 1.0_kind_phys - -contains - - subroutine get_phi_fv3_init() - end subroutine get_phi_fv3_init - -!! \section arg_table_get_phi_fv3_run Argument Table -!! \htmlinclude get_phi_fv3_run.html -!! - subroutine get_phi_fv3_run(ix, levs, con_fvirt, gt0, gq01, del_gz, phii, phil, errmsg, errflg) - - implicit none - - ! Interface variables - integer, intent(in) :: ix, levs - real(kind=kind_phys), intent(in) :: con_fvirt - real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 - real(kind=kind_phys), dimension(:,:), intent(in) :: gq01 - real(kind=kind_phys), dimension(:,:), intent(inout) :: del_gz - real(kind=kind_phys), dimension(:,:), intent(out) :: phii - real(kind=kind_phys), dimension(:,:), intent(out) :: phil - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i, k - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! SJL: Adjust the height hydrostatically in a way consistent with FV3 discretization - do i=1,ix - phii(i,1) = zero - enddo - do k=1,levs - do i=1,ix - del_gz(i,k) = del_gz(i,k)*gt0(i,k) * & - & (one + con_fvirt*max(zero,gq01(i,k))) - phii(i,k+1) = phii(i,k) + del_gz(i,k) - phil(i,k) = half*(phii(i,k) + phii(i,k+1)) - enddo - enddo - - end subroutine get_phi_fv3_run - - subroutine get_phi_fv3_finalize() - end subroutine get_phi_fv3_finalize - -end module get_phi_fv3 - - +end module get_prs_fv3 \ No newline at end of file diff --git a/physics/get_prs_fv3.meta b/physics/get_prs_fv3.meta index 4e893b45c..c26f5c308 100644 --- a/physics/get_prs_fv3.meta +++ b/physics/get_prs_fv3.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = get_prs_fv3 type = scheme - dependencies = machine.F,physcons.F90 + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -91,93 +91,4 @@ units = 1 dimensions = () type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = get_phi_fv3 - type = scheme - dependencies = machine.F,physcons.F90 - -######################################################################## -[ccpp-arg-table] - name = get_phi_fv3_run - type = scheme -[ix] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical layers - units = count - dimensions = () - type = integer - intent = in -[con_fvirt] - standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one - long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = updated air temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq01] - standard_name = specific_humidity_of_new_state - long_name = mid-layer specific humidity of water vapor - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[del_gz] - standard_name = geopotential_difference_between_midlayers_divided_by_midlayer_virtual_temperature - long_name = difference between mid-layer geopotentials divided by mid-layer virtual temperature - units = m2 s-2 K-1 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[phii] - standard_name = geopotential_at_interface - long_name = interface geopotential - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = out -[phil] - standard_name = geopotential - long_name = mid-layer geopotential - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - 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 - + intent = out \ No newline at end of file diff --git a/physics/gwdc.f b/physics/gwdc.f index 086662e73..8ece20aea 100644 --- a/physics/gwdc.f +++ b/physics/gwdc.f @@ -2,83 +2,6 @@ !! stationary convection forced gravity wave drag based on !! Chun and Baik (1998) \cite chun_and_baik_1998. -!> This module contains the CCPP-compliant convective gravity -!! wave drag pre interstitial codes. - module gwdc_pre - contains - - subroutine gwdc_pre_init() - end subroutine gwdc_pre_init - -! \brief Brief description of the subroutine -!! -!! \section arg_table_gwdc_pre_run Argument Table -!! \htmlinclude gwdc_pre_run.html -!! - subroutine gwdc_pre_run ( & - & im, cgwf, dx, work1, work2, dlength, cldf, & - & levs, kbot, ktop, dtp, gt0, gt0_init, del, cumabs, & - & errmsg, errflg ) - - use machine, only : kind_phys - implicit none - - integer, intent(in) :: im, levs - integer, intent(in) :: kbot(:), ktop(:) - real(kind=kind_phys), intent(in) :: dtp - real(kind=kind_phys), intent(in) :: cgwf(:) - real(kind=kind_phys), intent(in) :: dx(:), work1(:), work2(:) - real(kind=kind_phys), intent(in) :: & - & gt0(:,:), gt0_init(:,:), del(:,:) - - real(kind=kind_phys), intent(out) :: & - & dlength(:), cldf(:), cumabs(:) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k - real(kind=kind_phys) :: tem1, tem2 - real(kind=kind_phys) :: work3(im) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i = 1, im - tem1 = dx(i) - tem2 = tem1 - dlength(i) = sqrt( tem1*tem1+tem2*tem2 ) - cldf(i) = cgwf(1)*work1(i) + cgwf(2)*work2(i) - enddo - -! --- ... calculate maximum convective heating rate -! cuhr = temperature change due to deep convection - - cumabs(:) = 0.0 - work3(:) = 0.0 - do k = 1, levs - do i = 1, im - if (k >= kbot(i) .and. k <= ktop(i)) then - cumabs(i) & - & = cumabs(i) + (gt0(i,k) - gt0_init(i,k)) * del(i,k) - work3(i) = work3(i) + del(i,k) - endif - enddo - enddo - do i=1,im - if (work3(i) > 0.0) cumabs(i) = cumabs(i) / (dtp*work3(i)) - enddo - - end subroutine gwdc_pre_run - - subroutine gwdc_pre_finalize () - end subroutine gwdc_pre_finalize - - end module gwdc_pre - -!> This module contains the CCPP-compliant -!! convective gravity wave drag scheme. module gwdc contains @@ -1437,97 +1360,4 @@ subroutine gwdc_run (im,km,lat,u1,v1,t1,q1,deltim, & end subroutine gwdc_run !> @} - subroutine gwdc_finalize() - end subroutine gwdc_finalize - - end module gwdc - -!> This module contains the CCPP-compliant convective gravity wave -!! drag post intersititial codes. - module gwdc_post - - contains - - subroutine gwdc_post_init() - end subroutine gwdc_post_init - -! \brief Brief description of the subroutine -!! -!> \section arg_table_gwdc_post_run Argument Table -!! \htmlinclude gwdc_post_run.html -!! - subroutine gwdc_post_run( & - & im, levs, lssav, ldiag3d, dtf, dtp, con_cp, & - & tauctx, taucty, gwdcu, gwdcv, & - & dugwd, dvgwd, dtend, dtidx, index_of_x_wind, index_of_y_wind, & - & index_of_process_nonorographic_gwd, gu0, gv0, gt0, & - & errmsg, errflg) - - use machine, only : kind_phys - implicit none - - integer, intent(in) :: im, levs - logical, intent(in) :: lssav, ldiag3d - real(kind=kind_phys), intent(in) :: dtf, dtp, con_cp - real(kind=kind_phys), intent(in) :: & - & tauctx(:), taucty(:), gwdcu(:,:), gwdcv(:,:) - - real(kind=kind_phys), intent(inout) :: dugwd(:), dvgwd(:), & - & gu0(:,:), gv0(:,:), gt0(:,:) - real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) - integer, intent(in) :: dtidx(:,:) - integer, intent(in) :: index_of_process_nonorographic_gwd - integer, intent(in) :: index_of_x_wind, index_of_y_wind - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k, idtend - real(kind=kind_phys) :: eng0, eng1 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! --- ... write out cloud top stress and wind tendencies - - if (lssav) then - dugwd(:) = dugwd(:) + tauctx(:)*dtf - dvgwd(:) = dvgwd(:) + taucty(:)*dtf - endif ! end if_lssav - - if (ldiag3d) then - idtend = dtidx(index_of_x_wind,index_of_process_nonorographic_g& - & wd) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + gwdcu(:,:) * dtf - endif - idtend = dtidx(index_of_y_wind,index_of_process_nonorographic_g& - & wd) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + gwdcv(:,:) * dtf - endif - endif - -! --- ... update the wind components with gwdc tendencies - - do k = 1, levs - do i = 1, im - eng0 = 0.5*(gu0(i,k)*gu0(i,k) + gv0(i,k)*gv0(i,k)) - gu0(i,k) = gu0(i,k) + gwdcu(i,k) * dtp - gv0(i,k) = gv0(i,k) + gwdcv(i,k) * dtp - eng1 = 0.5*(gu0(i,k)*gu0(i,k) + gv0(i,k)*gv0(i,k)) - gt0(i,k) = gt0(i,k) + (eng0-eng1)/(dtp*con_cp) - enddo -! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', -! &gwdcu(ipr,k), ' gv0=', gv0(ipr,k),' gwdcv=',gwdcv(ipr,k) -! &,' k=',k - enddo - - end subroutine gwdc_post_run - - subroutine gwdc_post_finalize() - end subroutine gwdc_post_finalize - - end module gwdc_post - + end module gwdc \ No newline at end of file diff --git a/physics/gwdc.meta b/physics/gwdc.meta index e61559e92..341879b0b 100644 --- a/physics/gwdc.meta +++ b/physics/gwdc.meta @@ -1,144 +1,3 @@ -[ccpp-table-properties] - name = gwdc_pre - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = gwdc_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[cgwf] - standard_name = tunable_parameters_for_convective_gravity_wave_drag - long_name = multiplication factors for convective gravity wave drag - units = none - dimensions = (2) - type = real - kind = kind_phys - intent = in -[dx] - standard_name = characteristic_grid_lengthscale - long_name = grid size in zonal direction - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dlength] - standard_name = characteristic_grid_length_scale - long_name = representative horizontal length scale of grid box - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[cldf] - standard_name = cloud_area_fraction - long_name = fraction of grid box area in which updrafts occur - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical layers - units = count - dimensions = () - type = integer - intent = in -[kbot] - standard_name = vertical_index_at_cloud_base - long_name = vertical index at cloud base - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[ktop] - standard_name = vertical_index_at_cloud_top - long_name = vertical index at cloud top - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = updated air temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gt0_init] - standard_name = air_temperature_save - long_name = air temperature before entering convection scheme - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[del] - standard_name = air_pressure_difference_between_midlayers - long_name = difference between mid-layer pressures - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cumabs] - standard_name = maximum_column_heating_rate - long_name = maximum heating rate in column - units = K s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - 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-table-properties] name = gwdc @@ -414,191 +273,4 @@ units = 1 dimensions = () type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = gwdc_post - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = gwdc_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical layers - units = count - dimensions = () - type = integer - intent = in -[lssav] - standard_name = flag_for_diagnostics - long_name = flag for calculating diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for calculating 3-D diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[dtf] - standard_name = timestep_for_dynamics - long_name = dynamics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[con_cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[tauctx] - standard_name = instantaneous_x_stress_due_to_gravity_wave_drag - long_name = zonal stress at cloud top due to convective gravity wave drag - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[taucty] - standard_name = instantaneous_y_stress_due_to_gravity_wave_drag - long_name = meridional stress at cloud top due to convective gravity wave drag - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[gwdcu] - standard_name = tendency_of_x_wind_due_to_convective_gravity_wave_drag - long_name = zonal wind tendency due to convective gravity wave drag - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gwdcv] - standard_name = tendency_of_y_wind_due_to_convective_gravity_wave_drag - long_name = meridional wind tendency due to convective gravity wave drag - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dugwd] - standard_name = time_integral_of_x_stress_due_to_gravity_wave_drag - long_name = integral over time of zonal stress due to gravity wave drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[dvgwd] - standard_name = time_integral_of_y_stress_due_to_gravity_wave_drag - long_name = integral over time of meridional stress due to gravity wave drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - active = (flag_for_diagnostics_3D) - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[index_of_x_wind] - standard_name = index_of_x_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_y_wind] - standard_name = index_of_y_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_nonorographic_gwd] - standard_name = index_of_nonorographic_gravity_wave_drag_process_in_cumulative_change_index - long_name = index of nonorographic gravity wave drag process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[gu0] - standard_name = x_wind_of_new_state - long_name = updated zonal wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[gv0] - standard_name = y_wind_of_new_state - long_name = updated meridional wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[gt0] - standard_name = air_temperature_of_new_state - long_name = updated air temperature - units = K - 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 - 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 + intent = out \ No newline at end of file diff --git a/physics/gwdc_post.f b/physics/gwdc_post.f new file mode 100644 index 000000000..62891ffd4 --- /dev/null +++ b/physics/gwdc_post.f @@ -0,0 +1,82 @@ +!> \file gwdc_post.f This file contains code to execute after the original code for parameterization of +!! stationary convection forced gravity wave drag based on +!! Chun and Baik (1998) \cite chun_and_baik_1998. + + module gwdc_post + + contains + +!> \section arg_table_gwdc_post_run Argument Table +!! \htmlinclude gwdc_post_run.html +!! + subroutine gwdc_post_run( & + & im, levs, lssav, ldiag3d, dtf, dtp, con_cp, & + & tauctx, taucty, gwdcu, gwdcv, & + & dugwd, dvgwd, dtend, dtidx, index_of_x_wind, index_of_y_wind, & + & index_of_process_nonorographic_gwd, gu0, gv0, gt0, & + & errmsg, errflg) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, levs + logical, intent(in) :: lssav, ldiag3d + real(kind=kind_phys), intent(in) :: dtf, dtp, con_cp + real(kind=kind_phys), intent(in) :: & + & tauctx(:), taucty(:), gwdcu(:,:), gwdcv(:,:) + + real(kind=kind_phys), intent(inout) :: dugwd(:), dvgwd(:), & + & gu0(:,:), gv0(:,:), gt0(:,:) + real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) + integer, intent(in) :: dtidx(:,:) + integer, intent(in) :: index_of_process_nonorographic_gwd + integer, intent(in) :: index_of_x_wind, index_of_y_wind + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k, idtend + real(kind=kind_phys) :: eng0, eng1 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +! --- ... write out cloud top stress and wind tendencies + + if (lssav) then + dugwd(:) = dugwd(:) + tauctx(:)*dtf + dvgwd(:) = dvgwd(:) + taucty(:)*dtf + endif ! end if_lssav + + if (ldiag3d) then + idtend = dtidx(index_of_x_wind,index_of_process_nonorographic_g& + & wd) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + gwdcu(:,:) * dtf + endif + idtend = dtidx(index_of_y_wind,index_of_process_nonorographic_g& + & wd) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + gwdcv(:,:) * dtf + endif + endif + +! --- ... update the wind components with gwdc tendencies + + do k = 1, levs + do i = 1, im + eng0 = 0.5*(gu0(i,k)*gu0(i,k) + gv0(i,k)*gv0(i,k)) + gu0(i,k) = gu0(i,k) + gwdcu(i,k) * dtp + gv0(i,k) = gv0(i,k) + gwdcv(i,k) * dtp + eng1 = 0.5*(gu0(i,k)*gu0(i,k) + gv0(i,k)*gv0(i,k)) + gt0(i,k) = gt0(i,k) + (eng0-eng1)/(dtp*con_cp) + enddo +! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', +! &gwdcu(ipr,k), ' gv0=', gv0(ipr,k),' gwdcv=',gwdcv(ipr,k) +! &,' k=',k + enddo + + end subroutine gwdc_post_run + + end module gwdc_post \ No newline at end of file diff --git a/physics/gwdc_post.meta b/physics/gwdc_post.meta new file mode 100644 index 000000000..25415b888 --- /dev/null +++ b/physics/gwdc_post.meta @@ -0,0 +1,186 @@ +######################################################################## +[ccpp-table-properties] + name = gwdc_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = gwdc_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical layers + units = count + dimensions = () + type = integer + intent = in +[lssav] + standard_name = flag_for_diagnostics + long_name = flag for calculating diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for calculating 3-D diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[dtf] + standard_name = timestep_for_dynamics + long_name = dynamics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[tauctx] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal stress at cloud top due to convective gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[taucty] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional stress at cloud top due to convective gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[gwdcu] + standard_name = tendency_of_x_wind_due_to_convective_gravity_wave_drag + long_name = zonal wind tendency due to convective gravity wave drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gwdcv] + standard_name = tendency_of_y_wind_due_to_convective_gravity_wave_drag + long_name = meridional wind tendency due to convective gravity wave drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dugwd] + standard_name = time_integral_of_x_stress_due_to_gravity_wave_drag + long_name = integral over time of zonal stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[dvgwd] + standard_name = time_integral_of_y_stress_due_to_gravity_wave_drag + long_name = integral over time of meridional stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + active = (flag_for_diagnostics_3D) + intent = inout +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_x_wind] + standard_name = index_of_x_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_y_wind] + standard_name = index_of_y_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_nonorographic_gwd] + standard_name = index_of_nonorographic_gravity_wave_drag_process_in_cumulative_change_index + long_name = index of nonorographic gravity wave drag process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[gu0] + standard_name = x_wind_of_new_state + long_name = updated zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gv0] + standard_name = y_wind_of_new_state + long_name = updated meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gt0] + standard_name = air_temperature_of_new_state + long_name = updated air temperature + units = K + 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 + 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/gwdc_pre.f b/physics/gwdc_pre.f new file mode 100644 index 000000000..e2dce0a61 --- /dev/null +++ b/physics/gwdc_pre.f @@ -0,0 +1,68 @@ +!> \file gwdc_pre.f This file is preparation for the original code for parameterization of +!! stationary convection forced gravity wave drag based on +!! Chun and Baik (1998) \cite chun_and_baik_1998. + + module gwdc_pre + contains + +!! \section arg_table_gwdc_pre_run Argument Table +!! \htmlinclude gwdc_pre_run.html +!! + subroutine gwdc_pre_run ( & + & im, cgwf, dx, work1, work2, dlength, cldf, & + & levs, kbot, ktop, dtp, gt0, gt0_init, del, cumabs, & + & errmsg, errflg ) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, levs + integer, intent(in) :: kbot(:), ktop(:) + real(kind=kind_phys), intent(in) :: dtp + real(kind=kind_phys), intent(in) :: cgwf(:) + real(kind=kind_phys), intent(in) :: dx(:), work1(:), work2(:) + real(kind=kind_phys), intent(in) :: & + & gt0(:,:), gt0_init(:,:), del(:,:) + + real(kind=kind_phys), intent(out) :: & + & dlength(:), cldf(:), cumabs(:) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k + real(kind=kind_phys) :: tem1, tem2 + real(kind=kind_phys) :: work3(im) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i = 1, im + tem1 = dx(i) + tem2 = tem1 + dlength(i) = sqrt( tem1*tem1+tem2*tem2 ) + cldf(i) = cgwf(1)*work1(i) + cgwf(2)*work2(i) + enddo + +! --- ... calculate maximum convective heating rate +! cuhr = temperature change due to deep convection + + cumabs(:) = 0.0 + work3(:) = 0.0 + do k = 1, levs + do i = 1, im + if (k >= kbot(i) .and. k <= ktop(i)) then + cumabs(i) & + & = cumabs(i) + (gt0(i,k) - gt0_init(i,k)) * del(i,k) + work3(i) = work3(i) + del(i,k) + endif + enddo + enddo + do i=1,im + if (work3(i) > 0.0) cumabs(i) = cumabs(i) / (dtp*work3(i)) + enddo + + end subroutine gwdc_pre_run + + end module gwdc_pre \ No newline at end of file diff --git a/physics/gwdc_pre.meta b/physics/gwdc_pre.meta new file mode 100644 index 000000000..63df59cfa --- /dev/null +++ b/physics/gwdc_pre.meta @@ -0,0 +1,140 @@ +[ccpp-table-properties] + name = gwdc_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = gwdc_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[cgwf] + standard_name = tunable_parameters_for_convective_gravity_wave_drag + long_name = multiplication factors for convective gravity wave drag + units = none + dimensions = (2) + type = real + kind = kind_phys + intent = in +[dx] + standard_name = characteristic_grid_lengthscale + long_name = grid size in zonal direction + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dlength] + standard_name = characteristic_grid_length_scale + long_name = representative horizontal length scale of grid box + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[cldf] + standard_name = cloud_area_fraction + long_name = fraction of grid box area in which updrafts occur + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical layers + units = count + dimensions = () + type = integer + intent = in +[kbot] + standard_name = vertical_index_at_cloud_base + long_name = vertical index at cloud base + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[ktop] + standard_name = vertical_index_at_cloud_top + long_name = vertical index at cloud top + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = updated air temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gt0_init] + standard_name = air_temperature_save + long_name = air temperature before entering convection scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = difference between mid-layer pressures + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cumabs] + standard_name = maximum_column_heating_rate + long_name = maximum heating rate in column + units = K s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + 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 \ No newline at end of file diff --git a/physics/m_micro_interstitial.F90 b/physics/m_micro_interstitial.F90 deleted file mode 100644 index 8d0132cf1..000000000 --- a/physics/m_micro_interstitial.F90 +++ /dev/null @@ -1,277 +0,0 @@ -!> \file m_micro_interstitial.F90 -!! This file contains subroutines that prepare data for and from the Morrison-Gettelman microphysics scheme -!! as part of the GFS physics suite. - module m_micro_pre - - implicit none - - contains - - subroutine m_micro_pre_init() - end subroutine m_micro_pre_init - -! \brief Brief description of the subroutine -!! -!! \section arg_table_m_micro_pre_run Argument Table -!! \htmlinclude m_micro_pre_run.html -!! - subroutine m_micro_pre_run (im, levs, do_shoc, skip_macro, fprcp, mg3_as_mg2, gq0_ice, gq0_water, gq0_rain, & - gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, gq0_graupel_nc, cld_shoc, cnvc, cnvw, tcr, tcrf, gt0, & - qrn, qsnw, qgl, ncpr, ncps, ncgl, cld_frc_MG, clw_water, clw_ice, clcn, errmsg, errflg ) - - use machine, only : kind_phys - implicit none - - integer, intent(in) :: im, levs, fprcp - logical, intent(in) :: do_shoc, mg3_as_mg2 - logical, intent(inout) :: skip_macro - real(kind=kind_phys), intent(in) :: tcr, tcrf - - real(kind=kind_phys), intent(in) :: & - gq0_ice(:,:), gq0_water(:,:), gq0_rain(:,:), gq0_snow(:,:), & - gq0_graupel(:,:), gq0_rain_nc(:,:), gq0_snow_nc(:,:), & - gq0_graupel_nc(:,:), cld_shoc(:,:), cnvc(:,:), cnvw(:,:), & - gt0(:,:) - - real(kind=kind_phys), intent(inout) :: & - qrn(:,:), qsnw(:,:), qgl(:,:), ncpr(:,:), ncps(:,:), ncgl(:,:), & - cld_frc_MG(:,:) - - real(kind=kind_phys), intent(out) :: clw_ice(:,:), clw_water(:,:) - - real(kind=kind_phys), intent(in) :: clcn(:,:) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k - real(kind=kind_phys) :: tem - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Acheng used clw here for other code to run smoothly and minimum change - ! to make the code work. However, the nc and clw should be treated - ! in other procceses too. August 28/2015; Hope that can be done next - ! year. I believe this will make the physical interaction more reasonable - ! Anning 12/5/2015 changed ntcw hold liquid only - skip_macro = do_shoc - if (do_shoc) then - if (fprcp == 0) then - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - cld_frc_MG(i,k) = cld_shoc(i,k) - enddo - enddo - else if ((abs(fprcp) == 1) .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) - ncpr(i,k) = gq0_rain_nc(i,k) - ncps(i,k) = gq0_snow_nc(i,k) - cld_frc_MG(i,k) = cld_shoc(i,k) - enddo - enddo - else - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) - qgl(i,k) = gq0_graupel(i,k) - ncpr(i,k) = gq0_rain_nc(i,k) - ncps(i,k) = gq0_snow_nc(i,k) - ncgl(i,k) = gq0_graupel_nc(i,k) - cld_frc_MG(i,k) = cld_shoc(i,k) - enddo - enddo - end if - else - if (fprcp == 0 ) then - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - enddo - enddo - elseif (abs(fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) - ncpr(i,k) = gq0_rain_nc(i,k) - ncps(i,k) = gq0_snow_nc(i,k) - enddo - enddo - else - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) - qgl(i,k) = gq0_graupel(i,k) - ncpr(i,k) = gq0_rain_nc(i,k) - ncps(i,k) = gq0_snow_nc(i,k) - ncgl(i,k) = gq0_graupel_nc(i,k) - enddo - enddo - endif - end if - - ! add convective cloud fraction - do k = 1,levs - do i = 1,im - cld_frc_MG(i,k) = min(1.0, cld_frc_MG(i,k) + clcn(i,k)) - enddo - enddo - - end subroutine m_micro_pre_run - - subroutine m_micro_pre_finalize () - end subroutine m_micro_pre_finalize - - end module m_micro_pre - -!> This module contains the CCPP-compliant MG microphysics -!! post intersititial codes. - module m_micro_post - - implicit none - - contains - - subroutine m_micro_post_init() - end subroutine m_micro_post_init - -! \brief Brief description of the subroutine -!! -!! \section arg_table_m_micro_post_run Argument Table -!! \htmlinclude m_micro_post_run.html -!! - subroutine m_micro_post_run( & - im, levs, fprcp, mg3_as_mg2, ncpr, ncps, ncgl, qrn, qsnw, qgl, & - gq0_ice, gq0_rain, gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, & - gq0_graupel_nc, ice, snow, graupel, dtp, errmsg, errflg) - - use machine, only : kind_phys - implicit none - - integer, intent(in) :: im, levs, fprcp - logical, intent(in) :: mg3_as_mg2 - - real(kind=kind_phys), intent(in ) :: ncpr(:,:) - real(kind=kind_phys), intent(in ) :: ncps(:,:) - real(kind=kind_phys), intent(in ) :: ncgl(:,:) - real(kind=kind_phys), intent(inout) :: qrn(:,:) - real(kind=kind_phys), intent(inout) :: qsnw(:,:) - real(kind=kind_phys), intent(inout) :: qgl(:,:) - real(kind=kind_phys), intent(in ) :: gq0_ice(:,:) - real(kind=kind_phys), intent(out ) :: gq0_rain(:,:) - real(kind=kind_phys), intent(out ) :: gq0_snow(:,:) - real(kind=kind_phys), intent(out ) :: gq0_graupel(:,:) - real(kind=kind_phys), intent(out ) :: gq0_rain_nc(:,:) - real(kind=kind_phys), intent(out ) :: gq0_snow_nc(:,:) - real(kind=kind_phys), intent(out ) :: gq0_graupel_nc(:,:) - real(kind=kind_phys), intent( out) :: ice(:) - real(kind=kind_phys), intent( out) :: snow(:) - real(kind=kind_phys), intent( out) :: graupel(:) - real(kind=kind_phys), intent(in ) :: dtp - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - real(kind=kind_phys), parameter :: qsmall = 1.0d-20 - real(kind=kind_phys), parameter :: con_p001 = 0.001d0 - real(kind=kind_phys), parameter :: con_day = 86400.0d0 - integer :: i, k - real(kind=kind_phys) :: tem - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 -! do k=1,levs -! write(1000+me,*)' maxwatnca=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt=',kdt -! enddo -! write(1000+me,*)' at latitude = ',lat -! tx1 = 1000.0 -! call moist_bud(im,ix,ix,levs,me,kdt,con_g,tx1,del,rain1 -! &, txa, clw(1,1,2), clw(1,1,1) -! &, gq0(1,1,1),gq0(1,1,ntcw),gq0(1,1,ntcw+1),' m_micro ') - -! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, & -! &' rainc=',diag%rainc(ipr)*86400.0 -! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) -! if(lprnt) write(0,*) ' aftgt0=',Stateout%gt0(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*) ' aftlsgq0=',stateout%gq0(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw1aft=',stateout%gq0(ipr,:,ntiw),' kdt=',kdt -! if (ntgl > 0 .and. lprnt) & -! write(0,*)' cgw1aft=',stateout%gq0(ipr,:,ntgl),' kdt=',kdt -! if (lprnt) write(0,*)' cloudsm=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt -! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt -! if (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt - - tem = dtp * con_p001 / con_day - if (abs(fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - if (abs(qrn(i,k)) < qsmall) qrn(i,k) = 0.0 - if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = 0.0 - gq0_rain(i,k) = qrn(i,k) - gq0_snow(i,k) = qsnw(i,k) - gq0_rain_nc(i,k) = ncpr(i,k) - gq0_snow_nc(i,k) = ncps(i,k) - enddo - enddo - do i=1,im - ice(i) = tem * gq0_ice(i,1) - snow(i) = tem * qsnw(i,1) - enddo - elseif (fprcp > 1) then - do k=1,levs - do i=1,im - if (abs(qrn(i,k)) < qsmall) qrn(i,k) = 0.0 - if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = 0.0 - if (abs(qgl(i,k)) < qsmall) qgl(i,k) = 0.0 - gq0_rain(i,k) = qrn(i,k) - gq0_snow(i,k) = qsnw(i,k) - gq0_graupel(i,k) = qgl(i,k) - gq0_rain_nc(i,k) = ncpr(i,k) - gq0_snow_nc(i,k) = ncps(i,k) - gq0_graupel_nc(i,k) = ncgl(i,k) - enddo - enddo - do i=1,im - ice(i) = tem * gq0_ice(i,1) - snow(i) = tem * qsnw(i,1) - graupel(i) = tem * qgl(i,1) - enddo - - endif - -! if (lprnt) write(0,*)' cloudsm=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt -! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt -! if (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt -! - - - end subroutine m_micro_post_run - - subroutine m_micro_post_finalize() - end subroutine m_micro_post_finalize - - end module m_micro_post diff --git a/physics/m_micro_post.F90 b/physics/m_micro_post.F90 new file mode 100644 index 000000000..a61ee4874 --- /dev/null +++ b/physics/m_micro_post.F90 @@ -0,0 +1,127 @@ +!> \file m_micro_post.F90 +!! This file contains subroutines that prepare data from the Morrison-Gettelman microphysics scheme +!! as part of the GFS physics suite. + + module m_micro_post + + implicit none + + contains + +!! \section arg_table_m_micro_post_run Argument Table +!! \htmlinclude m_micro_post_run.html +!! + subroutine m_micro_post_run( & + im, levs, fprcp, mg3_as_mg2, ncpr, ncps, ncgl, qrn, qsnw, qgl, & + gq0_ice, gq0_rain, gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, & + gq0_graupel_nc, ice, snow, graupel, dtp, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, levs, fprcp + logical, intent(in) :: mg3_as_mg2 + + real(kind=kind_phys), intent(in ) :: ncpr(:,:) + real(kind=kind_phys), intent(in ) :: ncps(:,:) + real(kind=kind_phys), intent(in ) :: ncgl(:,:) + real(kind=kind_phys), intent(inout) :: qrn(:,:) + real(kind=kind_phys), intent(inout) :: qsnw(:,:) + real(kind=kind_phys), intent(inout) :: qgl(:,:) + real(kind=kind_phys), intent(in ) :: gq0_ice(:,:) + real(kind=kind_phys), intent(out ) :: gq0_rain(:,:) + real(kind=kind_phys), intent(out ) :: gq0_snow(:,:) + real(kind=kind_phys), intent(out ) :: gq0_graupel(:,:) + real(kind=kind_phys), intent(out ) :: gq0_rain_nc(:,:) + real(kind=kind_phys), intent(out ) :: gq0_snow_nc(:,:) + real(kind=kind_phys), intent(out ) :: gq0_graupel_nc(:,:) + real(kind=kind_phys), intent( out) :: ice(:) + real(kind=kind_phys), intent( out) :: snow(:) + real(kind=kind_phys), intent( out) :: graupel(:) + real(kind=kind_phys), intent(in ) :: dtp + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + real(kind=kind_phys), parameter :: qsmall = 1.0d-20 + real(kind=kind_phys), parameter :: con_p001 = 0.001d0 + real(kind=kind_phys), parameter :: con_day = 86400.0d0 + integer :: i, k + real(kind=kind_phys) :: tem + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +! do k=1,levs +! write(1000+me,*)' maxwatnca=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt=',kdt +! enddo +! write(1000+me,*)' at latitude = ',lat +! tx1 = 1000.0 +! call moist_bud(im,ix,ix,levs,me,kdt,con_g,tx1,del,rain1 +! &, txa, clw(1,1,2), clw(1,1,1) +! &, gq0(1,1,1),gq0(1,1,ntcw),gq0(1,1,ntcw+1),' m_micro ') + +! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, & +! &' rainc=',diag%rainc(ipr)*86400.0 +! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) +! if(lprnt) write(0,*) ' aftgt0=',Stateout%gt0(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*) ' aftlsgq0=',stateout%gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw1aft=',stateout%gq0(ipr,:,ntiw),' kdt=',kdt +! if (ntgl > 0 .and. lprnt) & +! write(0,*)' cgw1aft=',stateout%gq0(ipr,:,ntgl),' kdt=',kdt +! if (lprnt) write(0,*)' cloudsm=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt +! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt +! if (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt + + tem = dtp * con_p001 / con_day + if (abs(fprcp) == 1 .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + if (abs(qrn(i,k)) < qsmall) qrn(i,k) = 0.0 + if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = 0.0 + gq0_rain(i,k) = qrn(i,k) + gq0_snow(i,k) = qsnw(i,k) + gq0_rain_nc(i,k) = ncpr(i,k) + gq0_snow_nc(i,k) = ncps(i,k) + enddo + enddo + do i=1,im + ice(i) = tem * gq0_ice(i,1) + snow(i) = tem * qsnw(i,1) + enddo + elseif (fprcp > 1) then + do k=1,levs + do i=1,im + if (abs(qrn(i,k)) < qsmall) qrn(i,k) = 0.0 + if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = 0.0 + if (abs(qgl(i,k)) < qsmall) qgl(i,k) = 0.0 + gq0_rain(i,k) = qrn(i,k) + gq0_snow(i,k) = qsnw(i,k) + gq0_graupel(i,k) = qgl(i,k) + gq0_rain_nc(i,k) = ncpr(i,k) + gq0_snow_nc(i,k) = ncps(i,k) + gq0_graupel_nc(i,k) = ncgl(i,k) + enddo + enddo + do i=1,im + ice(i) = tem * gq0_ice(i,1) + snow(i) = tem * qsnw(i,1) + graupel(i) = tem * qgl(i,1) + enddo + + endif + +! if (lprnt) write(0,*)' cloudsm=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt +! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt +! if (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt +! + + + end subroutine m_micro_post_run + + end module m_micro_post diff --git a/physics/m_micro_post.meta b/physics/m_micro_post.meta new file mode 100644 index 000000000..684ac3f21 --- /dev/null +++ b/physics/m_micro_post.meta @@ -0,0 +1,190 @@ +######################################################################## +[ccpp-table-properties] + name = m_micro_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = m_micro_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical layers + units = count + dimensions = () + type = integer + intent = in +[fprcp] + standard_name = number_of_frozen_precipitation_species + long_name = number of frozen precipitation species + units = count + dimensions = () + type = integer + intent = in +[mg3_as_mg2] + standard_name = flag_mg3_as_mg2 + long_name = flag for controlling prep for Morrison-Gettelman microphysics + units = flag + dimensions = () + type = logical + intent = in +[ncpr] + standard_name = local_rain_number_concentration + long_name = number concentration of rain local to physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ncps] + standard_name = local_snow_number_concentration + long_name = number concentration of snow local to physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ncgl] + standard_name = local_graupel_number_concentration + long_name = number concentration of graupel local to physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qrn] + standard_name = local_rain_water_mixing_ratio + long_name = ratio of mass of rain water to mass of dry air plus vapor (without condensates) local to physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qsnw] + standard_name = local_snow_water_mixing_ratio + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) local to physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qgl] + standard_name = local_graupel_mixing_ratio + long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) local to physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gq0_ice] + standard_name = cloud_ice_mixing_ratio_of_new_state + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq0_rain] + standard_name = rain_mixing_ratio_of_new_state + long_name = ratio of mass of rain water to mass of dry air plus vapor (without condensates) updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0_snow] + standard_name = snow_mixing_ratio_of_new_state + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0_graupel] + standard_name = graupel_mixing_ratio_of_new_state + long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0_rain_nc] + standard_name = mass_number_concentration_of_rain_of_new_state + long_name = number concentration of rain updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0_snow_nc] + standard_name = mass_number_concentration_of_snow_of_new_state + long_name = number concentration of snow updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0_graupel_nc] + standard_name = mass_number_concentration_of_graupel_of_new_state + long_name = number concentration of graupel updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[ice] + standard_name = lwe_thickness_of_ice_amount_on_dynamics_timestep + long_name = ice fall at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[snow] + standard_name = lwe_thickness_of_snow_amount_on_dynamics_timestep + long_name = snow fall at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[graupel] + standard_name = lwe_thickness_of_graupel_amount_on_dynamics_timestep + long_name = graupel fall at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + diff --git a/physics/m_micro_pre.F90 b/physics/m_micro_pre.F90 new file mode 100644 index 000000000..9893e0db1 --- /dev/null +++ b/physics/m_micro_pre.F90 @@ -0,0 +1,135 @@ +!> \file m_micro_pre.F90 +!! This file contains subroutines that prepare data for the Morrison-Gettelman microphysics scheme +!! as part of the GFS physics suite. + module m_micro_pre + + implicit none + + contains + +!! \section arg_table_m_micro_pre_run Argument Table +!! \htmlinclude m_micro_pre_run.html +!! + subroutine m_micro_pre_run (im, levs, do_shoc, skip_macro, fprcp, mg3_as_mg2, gq0_ice, gq0_water, gq0_rain, & + gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, gq0_graupel_nc, cld_shoc, cnvc, cnvw, tcr, tcrf, gt0, & + qrn, qsnw, qgl, ncpr, ncps, ncgl, cld_frc_MG, clw_water, clw_ice, clcn, errmsg, errflg ) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, levs, fprcp + logical, intent(in) :: do_shoc, mg3_as_mg2 + logical, intent(inout) :: skip_macro + real(kind=kind_phys), intent(in) :: tcr, tcrf + + real(kind=kind_phys), intent(in) :: & + gq0_ice(:,:), gq0_water(:,:), gq0_rain(:,:), gq0_snow(:,:), & + gq0_graupel(:,:), gq0_rain_nc(:,:), gq0_snow_nc(:,:), & + gq0_graupel_nc(:,:), cld_shoc(:,:), cnvc(:,:), cnvw(:,:), & + gt0(:,:) + + real(kind=kind_phys), intent(inout) :: & + qrn(:,:), qsnw(:,:), qgl(:,:), ncpr(:,:), ncps(:,:), ncgl(:,:), & + cld_frc_MG(:,:) + + real(kind=kind_phys), intent(out) :: clw_ice(:,:), clw_water(:,:) + + real(kind=kind_phys), intent(in) :: clcn(:,:) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k + real(kind=kind_phys) :: tem + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Acheng used clw here for other code to run smoothly and minimum change + ! to make the code work. However, the nc and clw should be treated + ! in other procceses too. August 28/2015; Hope that can be done next + ! year. I believe this will make the physical interaction more reasonable + ! Anning 12/5/2015 changed ntcw hold liquid only + skip_macro = do_shoc + if (do_shoc) then + if (fprcp == 0) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + cld_frc_MG(i,k) = cld_shoc(i,k) + enddo + enddo + else if ((abs(fprcp) == 1) .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + cld_frc_MG(i,k) = cld_shoc(i,k) + enddo + enddo + else + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + qgl(i,k) = gq0_graupel(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + ncgl(i,k) = gq0_graupel_nc(i,k) + cld_frc_MG(i,k) = cld_shoc(i,k) + enddo + enddo + end if + else + if (fprcp == 0 ) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + enddo + enddo + elseif (abs(fprcp) == 1 .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + enddo + enddo + else + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + qgl(i,k) = gq0_graupel(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + ncgl(i,k) = gq0_graupel_nc(i,k) + enddo + enddo + endif + end if + + ! add convective cloud fraction + do k = 1,levs + do i = 1,im + cld_frc_MG(i,k) = min(1.0, cld_frc_MG(i,k) + clcn(i,k)) + enddo + enddo + + end subroutine m_micro_pre_run + + end module m_micro_pre \ No newline at end of file diff --git a/physics/m_micro_interstitial.meta b/physics/m_micro_pre.meta similarity index 58% rename from physics/m_micro_interstitial.meta rename to physics/m_micro_pre.meta index c7c8a23fd..7ac592833 100644 --- a/physics/m_micro_interstitial.meta +++ b/physics/m_micro_pre.meta @@ -255,195 +255,4 @@ units = 1 dimensions = () type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = m_micro_post - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = m_micro_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical layers - units = count - dimensions = () - type = integer - intent = in -[fprcp] - standard_name = number_of_frozen_precipitation_species - long_name = number of frozen precipitation species - units = count - dimensions = () - type = integer - intent = in -[mg3_as_mg2] - standard_name = flag_mg3_as_mg2 - long_name = flag for controlling prep for Morrison-Gettelman microphysics - units = flag - dimensions = () - type = logical - intent = in -[ncpr] - standard_name = local_rain_number_concentration - long_name = number concentration of rain local to physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ncps] - standard_name = local_snow_number_concentration - long_name = number concentration of snow local to physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ncgl] - standard_name = local_graupel_number_concentration - long_name = number concentration of graupel local to physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qrn] - standard_name = local_rain_water_mixing_ratio - long_name = ratio of mass of rain water to mass of dry air plus vapor (without condensates) local to physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[qsnw] - standard_name = local_snow_water_mixing_ratio - long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) local to physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[qgl] - standard_name = local_graupel_mixing_ratio - long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) local to physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[gq0_ice] - standard_name = cloud_ice_mixing_ratio_of_new_state - long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq0_rain] - standard_name = rain_mixing_ratio_of_new_state - long_name = ratio of mass of rain water to mass of dry air plus vapor (without condensates) updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0_snow] - standard_name = snow_mixing_ratio_of_new_state - long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0_graupel] - standard_name = graupel_mixing_ratio_of_new_state - long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0_rain_nc] - standard_name = mass_number_concentration_of_rain_of_new_state - long_name = number concentration of rain updated by physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0_snow_nc] - standard_name = mass_number_concentration_of_snow_of_new_state - long_name = number concentration of snow updated by physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0_graupel_nc] - standard_name = mass_number_concentration_of_graupel_of_new_state - long_name = number concentration of graupel updated by physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[ice] - standard_name = lwe_thickness_of_ice_amount_on_dynamics_timestep - long_name = ice fall at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[snow] - standard_name = lwe_thickness_of_snow_amount_on_dynamics_timestep - long_name = snow fall at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[graupel] - standard_name = lwe_thickness_of_graupel_amount_on_dynamics_timestep - long_name = graupel fall at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[dtp] - standard_name = timestep_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - 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 - + intent = out \ No newline at end of file diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 9258b5256..22961458d 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -6,18 +6,6 @@ module sfc_nst contains -! \brief This subroutine is empty since there are no procedures that need to be done to initialize the GFS NSST code. -!! This subroutine is empty since there are no procedures that need to be done to initialize the GFS NSST code. -!! - subroutine sfc_nst_init - end subroutine sfc_nst_init - -! \brief This subroutine is empty since there are no procedures that need to be done to finalize the GFS NSST code. -!! This subroutine is empty since there are no procedures that need to be done to finalize the GFS NSST code. -!! - subroutine sfc_nst_finalize - end subroutine sfc_nst_finalize - !>\defgroup gfs_nst_main GFS Near-Surface Sea Temperature Scheme Module !> \brief This subroutine calls the Thermal Skin-layer and Diurnal Thermocline models to update the NSST profile. !! \section arg_table_sfc_nst_run Argument Table @@ -704,211 +692,4 @@ subroutine sfc_nst_run & return end subroutine sfc_nst_run !> @} - end module sfc_nst - -!> This module contains the CCPP-compliant GFS near-surface sea temperature pre -!! interstitial codes. - 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. -!! - subroutine sfc_nst_pre_init - end subroutine sfc_nst_pre_init - - subroutine sfc_nst_pre_finalize - end subroutine sfc_nst_pre_finalize - -!! \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 - -!> This module contains the CCPP-compliant GFS near-surface sea temperature post -!! interstitial codes. - module sfc_nst_post - - contains - -! \defgroup GFS_NSST_POST GFS Near-Surface Sea Temperature Post -!! \brief Brief description of the parameterization -!! - subroutine sfc_nst_post_init - end subroutine sfc_nst_post_init - -! \brief Brief description of the subroutine -!! - subroutine sfc_nst_post_finalize - end subroutine sfc_nst_post_finalize - -!> \brief Brief description of the subroutine -!! -!! \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_flake, 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, use_flake - 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. .not. use_flake(i)) 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 + end module sfc_nst \ No newline at end of file diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index d80ebf0cf..fa15749b6 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -616,331 +616,4 @@ units = 1 dimensions = () type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = sfc_nst_pre - type = scheme - dependencies = date_def.f,funcphys.f90,machine.F,module_nst_model.f90,module_nst_parameters.f90,module_nst_water_prop.f90 - -######################################################################## -[ccpp-arg-table] - name = sfc_nst_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[tgice] - standard_name = freezing_point_temperature_of_seawater - long_name = freezing point temperature of seawater - units = K - dimensions = () - type = real - kind = kind_phys - intent = in -[tsfco] - standard_name = sea_surface_temperature - long_name = sea surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tsurf_wat] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tseal] - standard_name = surface_skin_temperature_for_nsst - long_name = ocean surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[xt] - standard_name = heat_content_in_diurnal_thermocline - long_name = heat content in diurnal thermocline layer - units = K m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xz] - standard_name = diurnal_thermocline_layer_thickness - long_name = diurnal thermocline layer thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dt_cool] - standard_name = molecular_sublayer_temperature_correction_in_sea_water - long_name = sub-layer cooling amount - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[z_c] - standard_name = molecular_sublayer_thickness_in_sea_water - long_name = sub-layer cooling thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tref] - standard_name = reference_sea_surface_temperature - long_name = reference/foundation temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[cplflx] - standard_name = flag_for_surface_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[oceanfrac] - standard_name = sea_area_fraction - long_name = fraction of horizontal grid area occupied by ocean - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[nthreads] - standard_name = number_of_openmp_threads - long_name = number of OpenMP threads available for physics schemes - units = count - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = sfc_nst_post - type = scheme - dependencies = date_def.f,funcphys.f90,machine.F,module_nst_model.f90,module_nst_parameters.f90,module_nst_water_prop.f90 - -######################################################################## -[ccpp-arg-table] - name = sfc_nst_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[kdt] - standard_name = index_of_timestep - long_name = current time step index - units = index - dimensions = () - type = integer - intent = in -[rlapse] - standard_name = air_temperature_lapse_rate_constant - long_name = environmental air temperature lapse rate constant - units = K m-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[tgice] - standard_name = freezing_point_temperature_of_seawater - long_name = freezing point temperature of seawater - units = K - dimensions = () - type = real - kind = kind_phys - intent = in -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[oro] - standard_name = height_above_mean_sea_level - long_name = height_above_mean_sea_level - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[oro_uf] - standard_name = unfiltered_height_above_mean_sea_level - long_name = unfiltered height_above_mean_sea_level - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[nstf_name1] - standard_name = control_for_nsstm - long_name = NSSTM flag: off/uncoupled/coupled=0/1/2 - units = flag - dimensions = () - type = integer - intent = in -[nstf_name4] - standard_name = lower_bound_for_depth_of_sea_temperature_for_nsstm - long_name = zsea1 - units = mm - dimensions = () - type = integer - intent = in -[nstf_name5] - standard_name = upper_bound_for_depth_of_sea_temperature_for_nsstm - long_name = zsea2 - units = mm - dimensions = () - type = integer - intent = in -[xt] - standard_name = heat_content_in_diurnal_thermocline - long_name = heat content in diurnal thermocline layer - units = K m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xz] - standard_name = diurnal_thermocline_layer_thickness - long_name = diurnal thermocline layer thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dt_cool] - standard_name = molecular_sublayer_temperature_correction_in_sea_water - long_name = sub-layer cooling amount - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[z_c] - standard_name = molecular_sublayer_thickness_in_sea_water - long_name = sub-layer cooling thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tref] - standard_name = reference_sea_surface_temperature - long_name = reference/foundation temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xlon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tsurf_wat] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsfc_wat] - standard_name = surface_skin_temperature_over_water - long_name = surface skin temperature over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[nthreads] - standard_name = number_of_openmp_threads - long_name = number of OpenMP threads available for physics schemes - units = count - dimensions = () - type = integer - intent = in -[dtzm] - standard_name = mean_change_over_depth_in_sea_water_temperature - long_name = mean of dT(z) (zsea1 to zsea2) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - 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 + intent = out \ No newline at end of file diff --git a/physics/sfc_nst_post.f b/physics/sfc_nst_post.f new file mode 100644 index 000000000..80f96d3f8 --- /dev/null +++ b/physics/sfc_nst_post.f @@ -0,0 +1,92 @@ +!> \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_flake, 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, use_flake + 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. .not. use_flake(i)) 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_nst_post.meta new file mode 100644 index 000000000..aefa53bb0 --- /dev/null +++ b/physics/sfc_nst_post.meta @@ -0,0 +1,192 @@ +######################################################################## +[ccpp-table-properties] + name = sfc_nst_post + type = scheme + dependencies = machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 + +######################################################################## +[ccpp-arg-table] + name = sfc_nst_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[kdt] + standard_name = index_of_timestep + long_name = current time step index + units = index + dimensions = () + type = integer + intent = in +[rlapse] + standard_name = air_temperature_lapse_rate_constant + long_name = environmental air temperature lapse rate constant + units = K m-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[tgice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[oro] + standard_name = height_above_mean_sea_level + long_name = height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[oro_uf] + standard_name = unfiltered_height_above_mean_sea_level + long_name = unfiltered height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[nstf_name1] + standard_name = control_for_nsstm + long_name = NSSTM flag: off/uncoupled/coupled=0/1/2 + units = flag + dimensions = () + type = integer + intent = in +[nstf_name4] + standard_name = lower_bound_for_depth_of_sea_temperature_for_nsstm + long_name = zsea1 + units = mm + dimensions = () + type = integer + intent = in +[nstf_name5] + standard_name = upper_bound_for_depth_of_sea_temperature_for_nsstm + long_name = zsea2 + units = mm + dimensions = () + type = integer + intent = in +[xt] + standard_name = heat_content_in_diurnal_thermocline + long_name = heat content in diurnal thermocline layer + units = K m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xz] + standard_name = diurnal_thermocline_layer_thickness + long_name = diurnal thermocline layer thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dt_cool] + standard_name = molecular_sublayer_temperature_correction_in_sea_water + long_name = sub-layer cooling amount + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[z_c] + standard_name = molecular_sublayer_thickness_in_sea_water + long_name = sub-layer cooling thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tref] + standard_name = reference_sea_surface_temperature + long_name = reference/foundation temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tsurf_wat] + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfc_wat] + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[nthreads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in +[dtzm] + standard_name = mean_change_over_depth_in_sea_water_temperature + long_name = mean of dT(z) (zsea1 to zsea2) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + 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_nst_pre.f b/physics/sfc_nst_pre.f new file mode 100644 index 000000000..04a08f591 --- /dev/null +++ b/physics/sfc_nst_pre.f @@ -0,0 +1,99 @@ +!> \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 \ No newline at end of file diff --git a/physics/sfc_nst_pre.meta b/physics/sfc_nst_pre.meta new file mode 100644 index 000000000..88788ff5c --- /dev/null +++ b/physics/sfc_nst_pre.meta @@ -0,0 +1,133 @@ +######################################################################## +[ccpp-table-properties] + name = sfc_nst_pre + type = scheme + dependencies = machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 + +######################################################################## +[ccpp-arg-table] + name = sfc_nst_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[tgice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[tsfco] + standard_name = sea_surface_temperature + long_name = sea surface temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tsurf_wat] + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tseal] + standard_name = surface_skin_temperature_for_nsst + long_name = ocean surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[xt] + standard_name = heat_content_in_diurnal_thermocline + long_name = heat content in diurnal thermocline layer + units = K m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xz] + standard_name = diurnal_thermocline_layer_thickness + long_name = diurnal thermocline layer thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dt_cool] + standard_name = molecular_sublayer_temperature_correction_in_sea_water + long_name = sub-layer cooling amount + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[z_c] + standard_name = molecular_sublayer_thickness_in_sea_water + long_name = sub-layer cooling thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tref] + standard_name = reference_sea_surface_temperature + long_name = reference/foundation temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[cplflx] + standard_name = flag_for_surface_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[nthreads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file From eb92feeb948715a31d6902ad143f2ebc0ec98203 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Mon, 11 Apr 2022 19:35:44 +0000 Subject: [PATCH 163/217] "update following Joe's comments for RRFS-Smoke" --- physics/GFS_rrtmg_pre.F90 | 2 +- physics/module_MYNNPBL_wrapper.F90 | 33 +++-------------------------- physics/module_MYNNPBL_wrapper.meta | 14 ++++++++++++ physics/module_bl_mynn.F90 | 20 ----------------- 4 files changed, 18 insertions(+), 51 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index f29dbfd5e..a6cdc9eb2 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -608,7 +608,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & do k = 1, LMK do i = 1, IM ! 550nm (~18000/cm) - faersw1(i,k,10) = faersw1(i,k,10) + MAX(4.,smoke_ext(i,k) + dust_ext(i,k)) + faersw1(i,k,10) = faersw1(i,k,10) + MIN(4.,smoke_ext(i,k) + dust_ext(i,k)) enddo enddo endif diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index c1d93536f..8dd6c6532 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -159,7 +159,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & chem3d, frp, mix_chem, fire_turb, & + & chem3d, frp, mix_chem, fire_turb, nchem, ndvel, & & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: @@ -180,11 +180,8 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, intent(in) :: cplflx !smoke/chem - !logical, intent(in) :: mix_chem, fire_turb - !integer, intent(in) :: nchem, ndvel, kdvel - !for testing only: - !logical, parameter :: mix_chem=.false., fire_turb=.false. - integer, parameter :: nchem=2, ndvel=2, kdvel=1 + integer, intent(in) :: nchem, ndvel + integer, parameter :: kdvel=1 ! NAMELIST OPTIONS (INPUT): logical, intent(in) :: & @@ -286,19 +283,11 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), allocatable :: old_ozone(:,:) !smoke/chem arrays - ! real(kind=kind_phys), dimension(:,:), intent(inout), optional :: & - ! & qgrs_smoke_conc, qgrs_dust_conc real(kind_phys), dimension(:), intent(inout) :: frp logical, intent(in) :: mix_chem, fire_turb real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d real(kind=kind_phys), dimension(im) :: emis_ant_no real(kind=kind_phys), dimension(im,ndvel) :: vdep -!for testing only -! real(kind=kind_phys), dimension(im,levs) :: & -! & qgrs_smoke_conc, qgrs_dust_conc -! real(kind=kind_phys), allocatable, dimension(:,:,:) :: chem3d -! real(kind=kind_phys), dimension(im,ndvel) :: vdep !not passed in yet??? -! real(kind=kind_phys), dimension(im) :: frp, emis_ant_no !MYNN-2D real(kind=kind_phys), dimension(:), intent(in) :: & @@ -364,20 +353,8 @@ SUBROUTINE mynnedmf_wrapper_run( & endif !initialize arrays for test - !qgrs_smoke_conc = 1.0 - !qgrs_dust_conc = 1.0 - !FRP = 0. EMIS_ANT_NO = 0. vdep = 0. ! hli for chem dry deposition, 0 temporarily - !if (mix_chem) then - ! allocate ( chem3d(im,levs,nchem) ) - ! do k=1,levs - ! do i=1,im - ! chem3d(i,k,1)=qgrs_smoke_conc(i,k) - ! chem3d(i,k,2)=qgrs_dust_conc (i,k) - ! enddo - ! enddo - !endif ! Check incoming moist species to ensure non-negative values ! First, create height (dz) and pressure differences (delp) @@ -969,10 +946,6 @@ SUBROUTINE mynnedmf_wrapper_run( & deallocate(save_qke_adv) endif -! if(allocated(chem3d))then -! deallocate(chem3d) -! endif - CONTAINS SUBROUTINE dtend_helper(itracer,field,mult) diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index d9c2ebf50..217271110 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1343,6 +1343,20 @@ dimensions = () type = logical intent = in +[nchem] + standard_name = number_of_chemical_species_vertically_mixed + long_name = number of chemical vertically mixed + units = count + dimensions = () + type = integer + intent = in +[ndvel] + standard_name = number_of_chemical_species_deposited + long_name = number of chemical pbl deposited + units = count + dimensions = () + type = integer + intent = in [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 38dcc95df..f264cdd3c 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -5363,26 +5363,6 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & rhoinv(kts)=1./rho(kts) khdz(kts) =rhoz(kts)*dfh(kts) - khdz_old = khdz(kts) - khdz_back = pblh * 0.15 / dz(kts) - !Enhance diffusion over fires - IF ( fire_turb ) THEN - IF ( pblh < pblh_threshold ) THEN - IF ( emis_ant_no > no_threshold ) THEN -! khdz(kts) = MAX(khdz(kts),khdz_back) - khdz(kts) = MAX(1.1*khdz(kts), sqrt((emis_ant_no / no_threshold))/dz(kts)*rhoz(kts)) ! JLS 12/21/21 - ENDIF - IF ( frp > frp_threshold ) THEN - !kmaxfire = ceiling(log(curr_frp)) ! JLS 12/21/21 - need to bring in curr_frp - kmaxfire = ceiling(log(frp)) - IF (k .le. kmaxfire) THEN ! JLS -! khdz(kts) = MAX(khdz(kts),khdz_back) - khdz(kts) = MAX(1.1*khdz(kts),((log(frp))**2.- 2.*log(frp)) / dz(kts)*rhoz(kts)) ! JLS 12/21/21 - ENDIF ! JLS - ENDIF - ENDIF - ENDIF - DO k=kts+1,kte rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) rhoz(k) = MAX(rhoz(k),1E-4) From 235ec3825715dfb646afe00dc71b0c010ff9b661 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Wed, 13 Apr 2022 17:44:27 +0000 Subject: [PATCH 164/217] add progsigma_calc --- physics/progsigma_calc.f90 | 260 +++++++++++++++++++++++++++++++++++++ 1 file changed, 260 insertions(+) create mode 100644 physics/progsigma_calc.f90 diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 new file mode 100644 index 000000000..378d43ef4 --- /dev/null +++ b/physics/progsigma_calc.f90 @@ -0,0 +1,260 @@ +!>\file progsigma +!! This file contains the subroutine that calculates the prognostic +!! updraft area fraction that is used for closure computations in +!! saSAS deep and shallow convection. + +!>\ingroup samfdeepcnv +!! This subroutine computes a prognostic updraft area fraction +!! used in the closure computations in the samfdeepcnv.f scheme +!>\ingroup samfshalcnv +!! This subroutine computes a prognostic updraft area fracftion +!! used in the closure computations in the samfshalcnv. scheme +!!\section progsigma General Algorithm +!> @{ + + subroutine progsigma_calc (im,km,flag_init,flag_restart,flag_deep, & + del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, & + qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, & + do_ca, ca_closure, ca_entr, ca_trigger, nthresh, ca_deep, & + ca_turb,ca_micro,ca_shal,ca_rad,convcount,ca1,ca2,ca3,ca4, & + sigmain,sigmaout,sigmab,errmsg,errflg) +! +! + use machine, only : kind_phys + use funcphys, only : fpvs + + implicit none + +! intent in + integer, intent(in) :: im,km,kbcon1(im),ktcon(im) + real, intent(in) :: hvap,delt + real, intent(in) :: qgrs_dsave(im,km), q(im,km),del(im,km), & + qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & + omega_u(im,km),zeta(im,km),gdx(im) + logical, intent(in) :: flag_init,flag_restart,flag_deep,cnvflg(im) + real(kind=kind_phys), intent(in) :: nthresh + real(kind=kind_phys), intent(in) :: ca_deep(im) + real(kind=kind_phys), intent(out):: ca_turb(im), & + ca_micro(im),ca_rad(im),ca_shal(im),convcount(im),ca1(im), & + ca2(im),ca3(im),ca4(im) + logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger + + real(kind=kind_phys), intent(in) :: sigmain(im,km) + +! intent out + real(kind=kind_phys), intent(out) :: sigmaout(im,km) + real(kind=kind_phys), intent(out) :: sigmab(im) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! Local variables + integer :: i,k,km1 + real(kind=kind_phys) :: termA(im),termB(im),termC(im),termD(im), & + mcons(im),zfdqa(im),zform(im,km), & + qadv(im,km),sigmamax(im) + + + real(kind=kind_phys) :: gcvalmx,ZEPS7,ZZ,ZCVG,mcon,buy2, & + zfdqb,dtdyn,dxlim,rmulacvg,dp,tem, & + alpha,DEN + integer :: inbu(im,km) + + !Parameters + gcvalmx = 0.1 + rmulacvg=10. + ZEPS7=1.E-11 + km1=km-1 + alpha=7000. + + !Initialization 2D + do k = 1,km + do i = 1,im + sigmaout(i,k)=0. + inbu(i,k)=0 + zform(i,k)=0. + enddo + enddo + + !Initialization 1D + do i=1,im + sigmab(i)=0. + sigmamax(i)=0.95 + termA(i)=0. + termB(i)=0. + termC(i)=0. + termD(i)=0. + zfdqa(i)=0. + mcons(i)=0. + enddo + + !Temporary Initialization output: + do i = 1,im + if(flag_deep)then + !ca_turb(i)=0. + ca_shal(i)=0. + endif + if(.not. flag_deep)then + ca_rad(i)=0. + convcount(i)=0. + ca1(i)=0. + endif + enddo + + !Initial computations, place maximum sigmain in sigmab + + do k=2,km + do i=1,im + if(flag_init .and. .not. flag_restart)then + if(cnvflg(i))then + sigmab(i)=0.03 + endif + else + if(cnvflg(i))then + !if(sigmain(i,k)<1.E-5)then + ! sigmain(i,k)=0. + !endif + if(sigmain(i,k)>sigmab(i))then + sigmab(i)=sigmain(i,k) + endif + endif + endif + enddo + enddo + + do i=1,im + if(sigmab(i) < 1.E-5)then !after advection + sigmab(i)=0. + endif + enddo + + !Initial computations, sigmamax + do i=1,im + sigmamax(i)=alpha/gdx(i) + sigmamax(i)=MIN(0.95,sigmamax(i)) + enddo + + !Initial computations, dynamic q-tendency + do k = 1,km + do i = 1,im + if(flag_init .and. .not.flag_restart)then + qadv(i,k)=0. + else + qadv(i,k)=(q(i,k) - qgrs_dsave(i,k))/delt + endif + enddo + enddo + + !compute termD "The vertical integral of the latent heat convergence is limited to the + !buoyant layers with positive moisture convergence (accumulated from the surface). + !Lowest level: + do i = 1,im + dp = 1000. * del(i,1) + mcons(i)=(hvap*(qadv(i,1)+tmf(i,1)+qmicro(i,1))*dp) + enddo + !Levels above: + do k = 2,km1 + do i = 1,im + dp = 1000. * del(i,k) + if(cnvflg(i))then + mcon = (hvap*(qadv(i,k)+tmf(i,k)+qmicro(i,k))*dp) + buy2 = termD(i)+mcon+mcons(i) +! Do the integral over buoyant layers with positive mcon acc from surface + if(k > kbcon1(i) .and. k < ktcon(i) .and. buy2 > 0.)then + inbu(i,k)=1 + endif + inbu(i,k-1)=MAX(inbu(i,k-1),inbu(i,k)) + termD(i) = termD(i) + float(inbu(i,k-1))*mcons(i) + mcons(i)=mcon + endif + enddo + enddo + + !termA + do k = 2,km1 + do i = 1,im + dp = 1000. * del(i,k) + if(cnvflg(i))then + tem=(sigmab(i)*zeta(i,k)*float(inbu(i,k))*dbyo1(i,k))*dp + termA(i)=termA(i)+tem + endif + enddo + enddo + + !termB + do k = 2,km1 + do i = 1,im + dp = 1000. * del(i,k) + if(cnvflg(i))then + tem=(dbyo1(i,k)*float(inbu(i,k)))*dp + termB(i)=termB(i)+tem + endif + enddo + enddo + + !termC + do k = 2,km1 + do i = 1,im + if(cnvflg(i))then + dp = 1000. * del(i,k) + zform(i,k)=-1.0*float(inbu(i,k))*(omega_u(i,k)*delt) + zfdqb=0.5*((zform(i,k)*zdqca(i,k))) + termC(i)=termC(i)+(float(inbu(i,k))* & + (zfdqb+zfdqa(i))*hvap*zeta(i,k)) + zfdqa(i)=zfdqb + endif + enddo + enddo + + !sigmab + do i = 1,im + if(cnvflg(i))then + + DEN=MIN(termC(i)+termB(i),1.E8) !1.E8 + !DEN=MAX(termC(i)+termB(i),1.E7) !1.E7 + + ZCVG=termD(i)*delt + + ZZ=MAX(0.0,SIGN(1.0,termA(i))) & + *MAX(0.0,SIGN(1.0,termB(i))) & + *MAX(0.0,SIGN(1.0,termC(i)-ZEPS7)) + + + ZCVG=MAX(0.0,ZCVG) + + if(flag_init)then + sigmab(i)=0.03 + else + sigmab(i)=(ZZ*(termA(i)+ZCVG))/(DEN+(1.0-ZZ)) + endif + + if(sigmab(i)>0.)then + sigmab(i)=MIN(sigmab(i),sigmamax(i)) + sigmab(i)=MAX(sigmab(i),0.01) + endif + + if(flag_deep)then + !ca_turb(i)=ZCVG + ca_shal(i)=termC(i) + else + ca_rad(i)=ZCVG + ca1(i)=termC(i) + endif + !ca3(i)=sigmab(i) + + endif!cnvflg + enddo + + do k=1,km + do i=1,im + if(cnvflg(i))then + sigmaout(i,k)=sigmab(i) + endif + enddo + enddo + + end subroutine progsigma_calc +!> @} +!! @} + + + From 3493525e5c1247ce7f9fba88bea9ff88614d4569 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 13 Apr 2022 17:34:07 -0400 Subject: [PATCH 165/217] rename files to their module names + split GFS_surface_generic --- ...neric.F90 => GFS_surface_generic_post.F90} | 239 +-------- ...ric.meta => GFS_surface_generic_post.meta} | 476 +----------------- physics/GFS_surface_generic_pre.F90 | 228 +++++++++ physics/GFS_surface_generic_pre.meta | 473 +++++++++++++++++ physics/{dcyc2.f => dcyc2t3.f} | 0 physics/{dcyc2.meta => dcyc2t3.meta} | 0 .../{gfdl_fv_sat_adj.F90 => fv_sat_adj.F90} | 0 .../{gfdl_fv_sat_adj.meta => fv_sat_adj.meta} | 0 physics/{moninedmf.f => hedmf.f} | 0 physics/{moninedmf.meta => hedmf.meta} | 0 physics/{sfc_drv.f => lsm_noah.f} | 0 physics/{sfc_drv.meta => lsm_noah.meta} | 0 physics/{sfc_drv_ruc.F90 => lsm_ruc.F90} | 0 physics/{sfc_drv_ruc.meta => lsm_ruc.meta} | 0 ..._MYJPBL_wrapper.F90 => myjpbl_wrapper.F90} | 0 ...YJPBL_wrapper.meta => myjpbl_wrapper.meta} | 0 ..._MYJSFC_wrapper.F90 => myjsfc_wrapper.F90} | 0 ...YJSFC_wrapper.meta => myjsfc_wrapper.meta} | 0 ...YNNPBL_wrapper.F90 => mynnpbl_wrapper.F90} | 0 ...NPBL_wrapper.meta => mynnpbl_wrapper.meta} | 0 ...YNNSFC_wrapper.F90 => mynnsfc_wrapper.F90} | 0 ...NSFC_wrapper.meta => mynnsfc_wrapper.meta} | 0 physics/{sfc_noahmp_drv.F90 => noahmpdrv.F90} | 0 .../{sfc_noahmp_drv.meta => noahmpdrv.meta} | 0 ...Cloud_RadPost.F90 => sgscloud_radpost.F90} | 2 +- ...oud_RadPost.meta => sgscloud_radpost.meta} | 0 ...GSCloud_RadPre.F90 => sgscloud_radpre.F90} | 2 +- ...Cloud_RadPre.meta => sgscloud_radpre.meta} | 0 physics/{gcm_shoc.F90 => shoc.F90} | 0 physics/{gcm_shoc.meta => shoc.meta} | 0 physics/{gscond.f => zhaocarr_gscond.f} | 0 physics/{gscond.meta => zhaocarr_gscond.meta} | 0 physics/{precpd.f => zhaocarr_precpd.f} | 0 physics/{precpd.meta => zhaocarr_precpd.meta} | 0 34 files changed, 707 insertions(+), 713 deletions(-) rename physics/{GFS_surface_generic.F90 => GFS_surface_generic_post.F90} (56%) rename physics/{GFS_surface_generic.meta => GFS_surface_generic_post.meta} (70%) create mode 100644 physics/GFS_surface_generic_pre.F90 create mode 100644 physics/GFS_surface_generic_pre.meta rename physics/{dcyc2.f => dcyc2t3.f} (100%) rename physics/{dcyc2.meta => dcyc2t3.meta} (100%) rename physics/{gfdl_fv_sat_adj.F90 => fv_sat_adj.F90} (100%) rename physics/{gfdl_fv_sat_adj.meta => fv_sat_adj.meta} (100%) rename physics/{moninedmf.f => hedmf.f} (100%) rename physics/{moninedmf.meta => hedmf.meta} (100%) rename physics/{sfc_drv.f => lsm_noah.f} (100%) rename physics/{sfc_drv.meta => lsm_noah.meta} (100%) rename physics/{sfc_drv_ruc.F90 => lsm_ruc.F90} (100%) rename physics/{sfc_drv_ruc.meta => lsm_ruc.meta} (100%) rename physics/{module_MYJPBL_wrapper.F90 => myjpbl_wrapper.F90} (100%) rename physics/{module_MYJPBL_wrapper.meta => myjpbl_wrapper.meta} (100%) rename physics/{module_MYJSFC_wrapper.F90 => myjsfc_wrapper.F90} (100%) rename physics/{module_MYJSFC_wrapper.meta => myjsfc_wrapper.meta} (100%) rename physics/{module_MYNNPBL_wrapper.F90 => mynnpbl_wrapper.F90} (100%) rename physics/{module_MYNNPBL_wrapper.meta => mynnpbl_wrapper.meta} (100%) rename physics/{module_MYNNSFC_wrapper.F90 => mynnsfc_wrapper.F90} (100%) rename physics/{module_MYNNSFC_wrapper.meta => mynnsfc_wrapper.meta} (100%) rename physics/{sfc_noahmp_drv.F90 => noahmpdrv.F90} (100%) rename physics/{sfc_noahmp_drv.meta => noahmpdrv.meta} (100%) rename physics/{module_SGSCloud_RadPost.F90 => sgscloud_radpost.F90} (98%) rename physics/{module_SGSCloud_RadPost.meta => sgscloud_radpost.meta} (100%) rename physics/{module_SGSCloud_RadPre.F90 => sgscloud_radpre.F90} (99%) rename physics/{module_SGSCloud_RadPre.meta => sgscloud_radpre.meta} (100%) rename physics/{gcm_shoc.F90 => shoc.F90} (100%) rename physics/{gcm_shoc.meta => shoc.meta} (100%) rename physics/{gscond.f => zhaocarr_gscond.f} (100%) rename physics/{gscond.meta => zhaocarr_gscond.meta} (100%) rename physics/{precpd.f => zhaocarr_precpd.f} (100%) rename physics/{precpd.meta => zhaocarr_precpd.meta} (100%) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic_post.F90 similarity index 56% rename from physics/GFS_surface_generic.F90 rename to physics/GFS_surface_generic_post.F90 index aecc6fcf7..eba164c78 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic_post.F90 @@ -1,235 +1,5 @@ -!> \file GFS_surface_generic.F90 -!! Contains code related to all GFS surface schemes. - -!>\defgroup mod_GFS_surface_generic_pre GFS Surface Generic Pre module - module GFS_surface_generic_pre - - use machine, only: kind_phys - - implicit none - - private - - public GFS_surface_generic_pre_init, GFS_surface_generic_pre_finalize, GFS_surface_generic_pre_run - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - - contains - -!> \section arg_table_GFS_surface_generic_pre_init Argument Table -!! \htmlinclude GFS_surface_generic_pre_init.html -!! - subroutine GFS_surface_generic_pre_init (nthreads, im, slmsk, isot, ivegsrc, stype, vtype, slope, & - vtype_save, stype_save, slope_save, errmsg, errflg) - - implicit none - - ! Interface variables - integer, intent(in) :: nthreads, im, isot, ivegsrc - real(kind_phys), dimension(:), intent(in) :: slmsk - integer, dimension(:), intent(inout) :: vtype, stype, slope - integer, dimension(:), intent(out) :: vtype_save, stype_save, slope_save - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer, dimension(1:im) :: islmsk - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - islmsk = nint(slmsk) - - ! Save current values of vegetation, soil and slope type - vtype_save(:) = vtype(:) - stype_save(:) = stype(:) - slope_save(:) = slope(:) - - call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) - - end subroutine GFS_surface_generic_pre_init - - subroutine GFS_surface_generic_pre_finalize() - end subroutine GFS_surface_generic_pre_finalize - -!> \section arg_table_GFS_surface_generic_pre_run Argument Table -!! \htmlinclude GFS_surface_generic_pre_run.html -!! - subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & - prsik_1, prslk_1, tsfc, phil, con_g, sigmaf, work3, zlvl, & - drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & - lndp_var_list, lndp_prt_list, & - z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, & - cplflx, flag_cice, islmsk_cice, slimskin_cpl, & - wind, u1, v1, cnvwind, smcwlt2, smcref2, vtype_save, stype_save, slope_save, & - errmsg, errflg) - - use surface_perturbation, only: cdfnor - - implicit none - - ! Interface variables - integer, intent(in) :: nthreads, im, levs, isot, ivegsrc - integer, dimension(:), intent(in) :: islmsk - - real(kind=kind_phys), intent(in) :: con_g - real(kind=kind_phys), dimension(:), intent(in) :: vfrac, prsik_1, prslk_1 - integer, dimension(:), intent(inout) :: vtype, stype, slope - integer, dimension(:), intent(out) :: vtype_save(:), stype_save(:), slope_save(:) - - real(kind=kind_phys), dimension(:), intent(inout) :: tsfc - real(kind=kind_phys), dimension(:,:), intent(in) :: phil - - real(kind=kind_phys), dimension(:), intent(inout) :: sigmaf, work3, zlvl - - ! Stochastic physics / surface perturbations - real(kind=kind_phys), dimension(:), intent(out) :: drain_cpl - real(kind=kind_phys), dimension(:), intent(out) :: dsnow_cpl - real(kind=kind_phys), dimension(:), intent(in) :: rain_cpl - real(kind=kind_phys), dimension(:), intent(in) :: snow_cpl - integer, intent(in) :: lndp_type, n_var_lndp - character(len=3), dimension(:), intent(in) :: lndp_var_list - real(kind=kind_phys), dimension(:), intent(in) :: lndp_prt_list - real(kind=kind_phys), dimension(:,:), intent(in) :: sfc_wts - real(kind=kind_phys), dimension(:), intent(out) :: z01d - real(kind=kind_phys), dimension(:), intent(out) :: zt1d - real(kind=kind_phys), dimension(:), intent(out) :: bexp1d - real(kind=kind_phys), dimension(:), intent(out) :: xlai1d - real(kind=kind_phys), dimension(:), intent(out) :: vegf1d - real(kind=kind_phys), intent(out) :: lndp_vgf - - logical, intent(in) :: cplflx - real(kind=kind_phys), dimension(:), intent(in) :: slimskin_cpl - logical, dimension(:), intent(inout) :: flag_cice - integer, dimension(:), intent(out) :: islmsk_cice - - real(kind=kind_phys), dimension(:), intent(out) :: wind - real(kind=kind_phys), dimension(:), intent(in ) :: u1, v1 - ! surface wind enhancement due to convection - real(kind=kind_phys), dimension(:), intent(inout ) :: cnvwind - ! - real(kind=kind_phys), dimension(:), intent(out) :: smcwlt2, smcref2 - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i, k - real(kind=kind_phys) :: onebg, cdfz - - ! Set constants - onebg = 1.0/con_g - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Scale random patterns for surface perturbations with perturbation size - ! Turn vegetation fraction pattern into percentile pattern - lndp_vgf=-999. - - if (lndp_type==1) then - do k =1,n_var_lndp - select case(lndp_var_list(k)) - case ('rz0') - z01d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('rzt') - zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('shc') - bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) - case ('lai') - xlai1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('vgf') - ! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff - do i=1,im - call cdfnor(sfc_wts(i,k),cdfz) - vegf1d(i) = cdfz - enddo - lndp_vgf = lndp_prt_list(k) - end select - enddo - endif - - ! End of stochastic physics / surface perturbation - - ! Save current values of vegetation, soil and slope type - vtype_save(:) = vtype(:) - stype_save(:) = stype(:) - slope_save(:) = slope(:) - - call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) - - do i=1,im - sigmaf(i) = max(vfrac(i), 0.01_kind_phys) - islmsk_cice(i) = islmsk(i) - - work3(i) = prsik_1(i) / prslk_1(i) - - zlvl(i) = phil(i,1) * onebg - smcwlt2(i) = zero - smcref2(i) = zero - - wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & - + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) - !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & - ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & - ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) - cnvwind(i) = zero - - enddo - - if (cplflx) then - do i=1,im - islmsk_cice(i) = nint(slimskin_cpl(i)) - flag_cice(i) = (islmsk_cice(i) == 4) - enddo - endif - - end subroutine GFS_surface_generic_pre_run - - subroutine update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) - - implicit none - - integer, intent(in) :: nthreads, im, isot, ivegsrc, islmsk(:) - integer, intent(inout) :: vtype(:), stype(:), slope(:) - integer :: i - -!$OMP parallel do num_threads(nthreads) default(none) private(i) & -!$OMP shared(im, isot, ivegsrc, islmsk, vtype, stype, slope) - do i=1,im - if (islmsk(i) == 2) then - if (isot == 1) then - stype(i) = 16 - else - stype(i) = 9 - endif - if (ivegsrc == 0 .or. ivegsrc == 4) then - vtype(i) = 24 - elseif (ivegsrc == 1) then - vtype(i) = 15 - elseif (ivegsrc == 2) then - vtype(i) = 13 - elseif (ivegsrc == 3 .or. ivegsrc == 5) then - vtype(i) = 15 - endif - slope(i) = 9 - else - if (vtype(i) < 1) vtype(i) = 17 - if (slope(i) < 1) slope(i) = 1 - endif - enddo -!$OMP end parallel do - - end subroutine update_vegetation_soil_slope_type - - end module GFS_surface_generic_pre - +!> \file GFS_surface_generic_post.F90 +!! Contains code related to all GFS surface schemes to be run afterward. module GFS_surface_generic_post @@ -239,7 +9,7 @@ module GFS_surface_generic_post private - public GFS_surface_generic_post_init, GFS_surface_generic_post_finalize, GFS_surface_generic_post_run + public GFS_surface_generic_post_init, GFS_surface_generic_post_run real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys @@ -268,9 +38,6 @@ subroutine GFS_surface_generic_post_init (vtype, stype, slope, vtype_save, stype end subroutine GFS_surface_generic_post_init - subroutine GFS_surface_generic_post_finalize() - end subroutine GFS_surface_generic_post_finalize - !> \section arg_table_GFS_surface_generic_post_run Argument Table !! \htmlinclude GFS_surface_generic_post_run.html !! diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic_post.meta similarity index 70% rename from physics/GFS_surface_generic.meta rename to physics/GFS_surface_generic_post.meta index a2493a825..033ec1cbf 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic_post.meta @@ -1,482 +1,8 @@ -[ccpp-table-properties] - name = GFS_surface_generic_pre - type = scheme - dependencies = machine.F,surface_perturbation.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_generic_pre_init - type = scheme -[nthreads] - standard_name = number_of_openmp_threads - long_name = number of OpenMP threads available for physics schemes - units = count - dimensions = () - type = integer - intent = in -[im] - standard_name = horizontal_dimension - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[slmsk] - standard_name = area_type - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[isot] - standard_name = control_for_soil_type_dataset - long_name = soil type dataset choice - units = index - dimensions = () - type = integer - intent = in -[ivegsrc] - standard_name = control_for_vegetation_dataset - long_name = land use dataset choice - units = index - dimensions = () - type = integer - intent = in -[stype] - standard_name = soil_type_classification - long_name = soil type for lsm - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[vtype] - standard_name = vegetation_type_classification - long_name = vegetation type for lsm - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[slope] - standard_name = surface_slope_classification - long_name = sfc slope type for lsm - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[stype_save] - standard_name = soil_type_classification_save - long_name = soil type for lsm save - units = index - dimensions = (horizontal_dimension) - type = integer - intent = out -[vtype_save] - standard_name = vegetation_type_classification_save - long_name = vegetation type for lsm save - units = index - dimensions = (horizontal_dimension) - type = integer - intent = out -[slope_save] - standard_name = surface_slope_classification_save - long_name = sfc slope type for lsm save - units = index - dimensions = (horizontal_dimension) - type = integer - intent = out -[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 = GFS_surface_generic_pre_run - type = scheme -[nthreads] - standard_name = number_of_openmp_threads - long_name = number of OpenMP threads available for physics schemes - units = count - dimensions = () - type = integer - intent = in -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[vfrac] - standard_name = vegetation_area_fraction - long_name = areal fractional cover of green vegetation - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[islmsk] - standard_name = sea_land_ice_mask - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[isot] - standard_name = control_for_soil_type_dataset - long_name = soil type dataset choice - units = index - dimensions = () - type = integer - intent = in -[ivegsrc] - standard_name = control_for_vegetation_dataset - long_name = land use dataset choice - units = index - dimensions = () - type = integer - intent = in -[stype] - standard_name = soil_type_classification - long_name = soil type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[vtype] - standard_name = vegetation_type_classification - long_name = vegetation type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[slope] - standard_name = surface_slope_classification - long_name = sfc slope type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[vtype_save] - standard_name = vegetation_type_classification_save - long_name = vegetation type for lsm save - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[stype_save] - standard_name = soil_type_classification_save - long_name = soil type for lsm save - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[slope_save] - standard_name = surface_slope_classification_save - long_name = sfc slope type for lsm save - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[prsik_1] - standard_name = surface_dimensionless_exner_function - long_name = dimensionless Exner function at lowest model interface - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[prslk_1] - standard_name = dimensionless_exner_function_at_surface_adjacent_layer - long_name = dimensionless Exner function at lowest model layer - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[phil] - standard_name = geopotential - long_name = geopotential at model layer centers - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[sigmaf] - standard_name = bounded_vegetation_area_fraction - long_name = areal fractional cover of green vegetation bounded on the bottom - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[work3] - standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer - long_name = Exner function ratio bt midlayer and interface at 1st layer - units = ratio - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[zlvl] - standard_name = height_above_ground_at_lowest_model_layer - long_name = layer 1 height above ground (not MSL) - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[drain_cpl] - standard_name = tendency_of_lwe_thickness_of_rain_amount_on_dynamics_timestep_for_coupling - long_name = change in rain_cpl (coupling_type) - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[dsnow_cpl] - standard_name = tendency_of_lwe_thickness_of_snowfall_amount_on_dynamics_timestep_for_coupling - long_name = change in show_cpl (coupling_type) - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[rain_cpl] - standard_name = cumulative_lwe_thickness_of_precipitation_amount_for_coupling - long_name = total rain precipitation - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[snow_cpl] - standard_name = cumulative_lwe_thickness_of_snow_amount_for_coupling - long_name = total snow precipitation - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lndp_type] - standard_name = control_for_stochastic_land_surface_perturbation - long_name = index for stochastic land surface perturbations type - units = index - dimensions = () - type = integer - intent = in -[n_var_lndp] - standard_name = number_of_perturbed_land_surface_variables - long_name = number of land surface variables perturbed - units = count - dimensions = () - type = integer - intent = in -[sfc_wts] - standard_name = surface_stochastic_weights_from_coupled_process - long_name = weights for stochastic surface physics perturbation - units = 1 - dimensions = (horizontal_loop_extent,number_of_perturbed_land_surface_variables) - type = real - kind = kind_phys - intent = in -[lndp_var_list] - standard_name = land_surface_perturbation_variables - long_name = variables to be perturbed for landperts - units = none - dimensions = (number_of_perturbed_land_surface_variables) - type = character - kind = len=3 - intent = in -[lndp_prt_list] - standard_name =land_surface_perturbation_magnitudes - long_name = magnitude of perturbations for landperts - units = variable - dimensions = (number_of_perturbed_land_surface_variables) - type = real - kind = kind_phys - intent = in -[z01d] - standard_name = perturbation_of_momentum_roughness_length - long_name = perturbation of momentum roughness length - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[zt1d] - standard_name = perturbation_of_heat_to_momentum_roughness_length_ratio - long_name = perturbation of heat to momentum roughness length ratio - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[bexp1d] - standard_name = perturbation_of_soil_type_b_parameter - long_name = perturbation of soil type "b" parameter - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[xlai1d] - standard_name = perturbation_of_leaf_area_index - long_name = perturbation of leaf area index - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[vegf1d] - standard_name = perturbation_of_vegetation_fraction - long_name = perturbation of vegetation fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[lndp_vgf] - standard_name = magnitude_of_perturbation_of_vegetation_fraction - long_name = magnitude of perturbation of vegetation fraction - units = frac - dimensions = () - type = real - kind = kind_phys - intent = out -[cplflx] - standard_name = flag_for_surface_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[islmsk_cice] - standard_name = sea_land_ice_mask_cice - long_name = sea/land/ice mask cice (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[slimskin_cpl] - standard_name = area_type_from_coupled_process - long_name = sea/land/ice mask input (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[wind] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[u1] - standard_name = x_wind_at_surface_adjacent_layer - long_name = zonal wind at lowest model layer - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[v1] - standard_name = y_wind_at_surface_adjacent_layer - long_name = meridional wind at lowest model layer - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[cnvwind] - standard_name = enhancement_to_wind_speed_at_surface_adjacent_layer_due_to_convection - long_name = surface wind enhancement due to convection - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[smcwlt2] - standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point - long_name = wilting point (volumetric) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[smcref2] - standard_name = threshold_volume_fraction_of_condensed_water_in_soil - long_name = soil moisture threshold (volumetric) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - 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-table-properties] name = GFS_surface_generic_post type = scheme - dependencies = machine.F,surface_perturbation.F90 + dependencies = machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_generic_pre.F90 b/physics/GFS_surface_generic_pre.F90 new file mode 100644 index 000000000..c572201a4 --- /dev/null +++ b/physics/GFS_surface_generic_pre.F90 @@ -0,0 +1,228 @@ +!> \file GFS_surface_generic_pre.F90 +!! Contains code related to running prior to all GFS surface schemes. + +!>\defgroup mod_GFS_surface_generic_pre GFS Surface Generic Pre module + module GFS_surface_generic_pre + + use machine, only: kind_phys + + implicit none + + private + + public GFS_surface_generic_pre_init, GFS_surface_generic_pre_run + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + + contains + +!> \section arg_table_GFS_surface_generic_pre_init Argument Table +!! \htmlinclude GFS_surface_generic_pre_init.html +!! + subroutine GFS_surface_generic_pre_init (nthreads, im, slmsk, isot, ivegsrc, stype, vtype, slope, & + vtype_save, stype_save, slope_save, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in) :: nthreads, im, isot, ivegsrc + real(kind_phys), dimension(:), intent(in) :: slmsk + integer, dimension(:), intent(inout) :: vtype, stype, slope + integer, dimension(:), intent(out) :: vtype_save, stype_save, slope_save + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer, dimension(1:im) :: islmsk + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + islmsk = nint(slmsk) + + ! Save current values of vegetation, soil and slope type + vtype_save(:) = vtype(:) + stype_save(:) = stype(:) + slope_save(:) = slope(:) + + call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) + + end subroutine GFS_surface_generic_pre_init + +!> \section arg_table_GFS_surface_generic_pre_run Argument Table +!! \htmlinclude GFS_surface_generic_pre_run.html +!! + subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & + prsik_1, prslk_1, tsfc, phil, con_g, sigmaf, work3, zlvl, & + drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & + lndp_var_list, lndp_prt_list, & + z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, & + cplflx, flag_cice, islmsk_cice, slimskin_cpl, & + wind, u1, v1, cnvwind, smcwlt2, smcref2, vtype_save, stype_save, slope_save, & + errmsg, errflg) + + use surface_perturbation, only: cdfnor + + implicit none + + ! Interface variables + integer, intent(in) :: nthreads, im, levs, isot, ivegsrc + integer, dimension(:), intent(in) :: islmsk + + real(kind=kind_phys), intent(in) :: con_g + real(kind=kind_phys), dimension(:), intent(in) :: vfrac, prsik_1, prslk_1 + integer, dimension(:), intent(inout) :: vtype, stype, slope + integer, dimension(:), intent(out) :: vtype_save(:), stype_save(:), slope_save(:) + + real(kind=kind_phys), dimension(:), intent(inout) :: tsfc + real(kind=kind_phys), dimension(:,:), intent(in) :: phil + + real(kind=kind_phys), dimension(:), intent(inout) :: sigmaf, work3, zlvl + + ! Stochastic physics / surface perturbations + real(kind=kind_phys), dimension(:), intent(out) :: drain_cpl + real(kind=kind_phys), dimension(:), intent(out) :: dsnow_cpl + real(kind=kind_phys), dimension(:), intent(in) :: rain_cpl + real(kind=kind_phys), dimension(:), intent(in) :: snow_cpl + integer, intent(in) :: lndp_type, n_var_lndp + character(len=3), dimension(:), intent(in) :: lndp_var_list + real(kind=kind_phys), dimension(:), intent(in) :: lndp_prt_list + real(kind=kind_phys), dimension(:,:), intent(in) :: sfc_wts + real(kind=kind_phys), dimension(:), intent(out) :: z01d + real(kind=kind_phys), dimension(:), intent(out) :: zt1d + real(kind=kind_phys), dimension(:), intent(out) :: bexp1d + real(kind=kind_phys), dimension(:), intent(out) :: xlai1d + real(kind=kind_phys), dimension(:), intent(out) :: vegf1d + real(kind=kind_phys), intent(out) :: lndp_vgf + + logical, intent(in) :: cplflx + real(kind=kind_phys), dimension(:), intent(in) :: slimskin_cpl + logical, dimension(:), intent(inout) :: flag_cice + integer, dimension(:), intent(out) :: islmsk_cice + + real(kind=kind_phys), dimension(:), intent(out) :: wind + real(kind=kind_phys), dimension(:), intent(in ) :: u1, v1 + ! surface wind enhancement due to convection + real(kind=kind_phys), dimension(:), intent(inout ) :: cnvwind + ! + real(kind=kind_phys), dimension(:), intent(out) :: smcwlt2, smcref2 + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i, k + real(kind=kind_phys) :: onebg, cdfz + + ! Set constants + onebg = 1.0/con_g + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Scale random patterns for surface perturbations with perturbation size + ! Turn vegetation fraction pattern into percentile pattern + lndp_vgf=-999. + + if (lndp_type==1) then + do k =1,n_var_lndp + select case(lndp_var_list(k)) + case ('rz0') + z01d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('rzt') + zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('shc') + bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) + case ('lai') + xlai1d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('vgf') + ! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff + do i=1,im + call cdfnor(sfc_wts(i,k),cdfz) + vegf1d(i) = cdfz + enddo + lndp_vgf = lndp_prt_list(k) + end select + enddo + endif + + ! End of stochastic physics / surface perturbation + + ! Save current values of vegetation, soil and slope type + vtype_save(:) = vtype(:) + stype_save(:) = stype(:) + slope_save(:) = slope(:) + + call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) + + do i=1,im + sigmaf(i) = max(vfrac(i), 0.01_kind_phys) + islmsk_cice(i) = islmsk(i) + + work3(i) = prsik_1(i) / prslk_1(i) + + zlvl(i) = phil(i,1) * onebg + smcwlt2(i) = zero + smcref2(i) = zero + + wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) + !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & + ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & + ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) + cnvwind(i) = zero + + enddo + + if (cplflx) then + do i=1,im + islmsk_cice(i) = nint(slimskin_cpl(i)) + flag_cice(i) = (islmsk_cice(i) == 4) + enddo + endif + + end subroutine GFS_surface_generic_pre_run + + subroutine update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) + + implicit none + + integer, intent(in) :: nthreads, im, isot, ivegsrc, islmsk(:) + integer, intent(inout) :: vtype(:), stype(:), slope(:) + integer :: i + +!$OMP parallel do num_threads(nthreads) default(none) private(i) & +!$OMP shared(im, isot, ivegsrc, islmsk, vtype, stype, slope) + do i=1,im + if (islmsk(i) == 2) then + if (isot == 1) then + stype(i) = 16 + else + stype(i) = 9 + endif + if (ivegsrc == 0 .or. ivegsrc == 4) then + vtype(i) = 24 + elseif (ivegsrc == 1) then + vtype(i) = 15 + elseif (ivegsrc == 2) then + vtype(i) = 13 + elseif (ivegsrc == 3 .or. ivegsrc == 5) then + vtype(i) = 15 + endif + slope(i) = 9 + else + if (vtype(i) < 1) vtype(i) = 17 + if (slope(i) < 1) slope(i) = 1 + endif + enddo +!$OMP end parallel do + + end subroutine update_vegetation_soil_slope_type + + end module GFS_surface_generic_pre diff --git a/physics/GFS_surface_generic_pre.meta b/physics/GFS_surface_generic_pre.meta new file mode 100644 index 000000000..f5b7f7f27 --- /dev/null +++ b/physics/GFS_surface_generic_pre.meta @@ -0,0 +1,473 @@ +[ccpp-table-properties] + name = GFS_surface_generic_pre + type = scheme + dependencies = machine.F,surface_perturbation.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_generic_pre_init + type = scheme +[nthreads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in +[im] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[slmsk] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[isot] + standard_name = control_for_soil_type_dataset + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in +[ivegsrc] + standard_name = control_for_vegetation_dataset + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in +[stype] + standard_name = soil_type_classification + long_name = soil type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[vtype] + standard_name = vegetation_type_classification + long_name = vegetation type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[slope] + standard_name = surface_slope_classification + long_name = sfc slope type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[stype_save] + standard_name = soil_type_classification_save + long_name = soil type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out +[vtype_save] + standard_name = vegetation_type_classification_save + long_name = vegetation type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out +[slope_save] + standard_name = surface_slope_classification_save + long_name = sfc slope type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out +[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 = GFS_surface_generic_pre_run + type = scheme +[nthreads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[vfrac] + standard_name = vegetation_area_fraction + long_name = areal fractional cover of green vegetation + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[islmsk] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[isot] + standard_name = control_for_soil_type_dataset + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in +[ivegsrc] + standard_name = control_for_vegetation_dataset + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in +[stype] + standard_name = soil_type_classification + long_name = soil type for lsm + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[vtype] + standard_name = vegetation_type_classification + long_name = vegetation type for lsm + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[slope] + standard_name = surface_slope_classification + long_name = sfc slope type for lsm + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[vtype_save] + standard_name = vegetation_type_classification_save + long_name = vegetation type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[stype_save] + standard_name = soil_type_classification_save + long_name = soil type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[slope_save] + standard_name = surface_slope_classification_save + long_name = sfc slope type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[prsik_1] + standard_name = surface_dimensionless_exner_function + long_name = dimensionless Exner function at lowest model interface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[prslk_1] + standard_name = dimensionless_exner_function_at_surface_adjacent_layer + long_name = dimensionless Exner function at lowest model layer + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[phil] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[work3] + standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer + long_name = Exner function ratio bt midlayer and interface at 1st layer + units = ratio + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[zlvl] + standard_name = height_above_ground_at_lowest_model_layer + long_name = layer 1 height above ground (not MSL) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[drain_cpl] + standard_name = tendency_of_lwe_thickness_of_rain_amount_on_dynamics_timestep_for_coupling + long_name = change in rain_cpl (coupling_type) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[dsnow_cpl] + standard_name = tendency_of_lwe_thickness_of_snowfall_amount_on_dynamics_timestep_for_coupling + long_name = change in show_cpl (coupling_type) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[rain_cpl] + standard_name = cumulative_lwe_thickness_of_precipitation_amount_for_coupling + long_name = total rain precipitation + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[snow_cpl] + standard_name = cumulative_lwe_thickness_of_snow_amount_for_coupling + long_name = total snow precipitation + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lndp_type] + standard_name = control_for_stochastic_land_surface_perturbation + long_name = index for stochastic land surface perturbations type + units = index + dimensions = () + type = integer + intent = in +[n_var_lndp] + standard_name = number_of_perturbed_land_surface_variables + long_name = number of land surface variables perturbed + units = count + dimensions = () + type = integer + intent = in +[sfc_wts] + standard_name = surface_stochastic_weights_from_coupled_process + long_name = weights for stochastic surface physics perturbation + units = 1 + dimensions = (horizontal_loop_extent,number_of_perturbed_land_surface_variables) + type = real + kind = kind_phys + intent = in +[lndp_var_list] + standard_name = land_surface_perturbation_variables + long_name = variables to be perturbed for landperts + units = none + dimensions = (number_of_perturbed_land_surface_variables) + type = character + kind = len=3 + intent = in +[lndp_prt_list] + standard_name =land_surface_perturbation_magnitudes + long_name = magnitude of perturbations for landperts + units = variable + dimensions = (number_of_perturbed_land_surface_variables) + type = real + kind = kind_phys + intent = in +[z01d] + standard_name = perturbation_of_momentum_roughness_length + long_name = perturbation of momentum roughness length + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[zt1d] + standard_name = perturbation_of_heat_to_momentum_roughness_length_ratio + long_name = perturbation of heat to momentum roughness length ratio + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[bexp1d] + standard_name = perturbation_of_soil_type_b_parameter + long_name = perturbation of soil type "b" parameter + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[xlai1d] + standard_name = perturbation_of_leaf_area_index + long_name = perturbation of leaf area index + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[vegf1d] + standard_name = perturbation_of_vegetation_fraction + long_name = perturbation of vegetation fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[lndp_vgf] + standard_name = magnitude_of_perturbation_of_vegetation_fraction + long_name = magnitude of perturbation of vegetation fraction + units = frac + dimensions = () + type = real + kind = kind_phys + intent = out +[cplflx] + standard_name = flag_for_surface_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[islmsk_cice] + standard_name = sea_land_ice_mask_cice + long_name = sea/land/ice mask cice (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[slimskin_cpl] + standard_name = area_type_from_coupled_process + long_name = sea/land/ice mask input (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[u1] + standard_name = x_wind_at_surface_adjacent_layer + long_name = zonal wind at lowest model layer + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[v1] + standard_name = y_wind_at_surface_adjacent_layer + long_name = meridional wind at lowest model layer + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cnvwind] + standard_name = enhancement_to_wind_speed_at_surface_adjacent_layer_due_to_convection + long_name = surface wind enhancement due to convection + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[smcwlt2] + standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point + long_name = wilting point (volumetric) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[smcref2] + standard_name = threshold_volume_fraction_of_condensed_water_in_soil + long_name = soil moisture threshold (volumetric) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + 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 \ No newline at end of file diff --git a/physics/dcyc2.f b/physics/dcyc2t3.f similarity index 100% rename from physics/dcyc2.f rename to physics/dcyc2t3.f diff --git a/physics/dcyc2.meta b/physics/dcyc2t3.meta similarity index 100% rename from physics/dcyc2.meta rename to physics/dcyc2t3.meta diff --git a/physics/gfdl_fv_sat_adj.F90 b/physics/fv_sat_adj.F90 similarity index 100% rename from physics/gfdl_fv_sat_adj.F90 rename to physics/fv_sat_adj.F90 diff --git a/physics/gfdl_fv_sat_adj.meta b/physics/fv_sat_adj.meta similarity index 100% rename from physics/gfdl_fv_sat_adj.meta rename to physics/fv_sat_adj.meta diff --git a/physics/moninedmf.f b/physics/hedmf.f similarity index 100% rename from physics/moninedmf.f rename to physics/hedmf.f diff --git a/physics/moninedmf.meta b/physics/hedmf.meta similarity index 100% rename from physics/moninedmf.meta rename to physics/hedmf.meta diff --git a/physics/sfc_drv.f b/physics/lsm_noah.f similarity index 100% rename from physics/sfc_drv.f rename to physics/lsm_noah.f diff --git a/physics/sfc_drv.meta b/physics/lsm_noah.meta similarity index 100% rename from physics/sfc_drv.meta rename to physics/lsm_noah.meta diff --git a/physics/sfc_drv_ruc.F90 b/physics/lsm_ruc.F90 similarity index 100% rename from physics/sfc_drv_ruc.F90 rename to physics/lsm_ruc.F90 diff --git a/physics/sfc_drv_ruc.meta b/physics/lsm_ruc.meta similarity index 100% rename from physics/sfc_drv_ruc.meta rename to physics/lsm_ruc.meta diff --git a/physics/module_MYJPBL_wrapper.F90 b/physics/myjpbl_wrapper.F90 similarity index 100% rename from physics/module_MYJPBL_wrapper.F90 rename to physics/myjpbl_wrapper.F90 diff --git a/physics/module_MYJPBL_wrapper.meta b/physics/myjpbl_wrapper.meta similarity index 100% rename from physics/module_MYJPBL_wrapper.meta rename to physics/myjpbl_wrapper.meta diff --git a/physics/module_MYJSFC_wrapper.F90 b/physics/myjsfc_wrapper.F90 similarity index 100% rename from physics/module_MYJSFC_wrapper.F90 rename to physics/myjsfc_wrapper.F90 diff --git a/physics/module_MYJSFC_wrapper.meta b/physics/myjsfc_wrapper.meta similarity index 100% rename from physics/module_MYJSFC_wrapper.meta rename to physics/myjsfc_wrapper.meta diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/mynnpbl_wrapper.F90 similarity index 100% rename from physics/module_MYNNPBL_wrapper.F90 rename to physics/mynnpbl_wrapper.F90 diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/mynnpbl_wrapper.meta similarity index 100% rename from physics/module_MYNNPBL_wrapper.meta rename to physics/mynnpbl_wrapper.meta diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/mynnsfc_wrapper.F90 similarity index 100% rename from physics/module_MYNNSFC_wrapper.F90 rename to physics/mynnsfc_wrapper.F90 diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/mynnsfc_wrapper.meta similarity index 100% rename from physics/module_MYNNSFC_wrapper.meta rename to physics/mynnsfc_wrapper.meta diff --git a/physics/sfc_noahmp_drv.F90 b/physics/noahmpdrv.F90 similarity index 100% rename from physics/sfc_noahmp_drv.F90 rename to physics/noahmpdrv.F90 diff --git a/physics/sfc_noahmp_drv.meta b/physics/noahmpdrv.meta similarity index 100% rename from physics/sfc_noahmp_drv.meta rename to physics/noahmpdrv.meta diff --git a/physics/module_SGSCloud_RadPost.F90 b/physics/sgscloud_radpost.F90 similarity index 98% rename from physics/module_SGSCloud_RadPost.F90 rename to physics/sgscloud_radpost.F90 index ea262596f..a7e68732c 100644 --- a/physics/module_SGSCloud_RadPost.F90 +++ b/physics/sgscloud_radpost.F90 @@ -1,4 +1,4 @@ -!> \file module_SGSCloud_RadPost.F90 +!> \file SGSCloud_RadPost.F90 !! Contains the post (interstitial) work after the call to the radiation schemes: !! 1) Restores the original qc & qi diff --git a/physics/module_SGSCloud_RadPost.meta b/physics/sgscloud_radpost.meta similarity index 100% rename from physics/module_SGSCloud_RadPost.meta rename to physics/sgscloud_radpost.meta diff --git a/physics/module_SGSCloud_RadPre.F90 b/physics/sgscloud_radpre.F90 similarity index 99% rename from physics/module_SGSCloud_RadPre.F90 rename to physics/sgscloud_radpre.F90 index 68a520a84..63c90131c 100644 --- a/physics/module_SGSCloud_RadPre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -1,4 +1,4 @@ -!>\file module_SGSCloud_RadPre.F90 +!>\file SGSCloud_RadPre.F90 !! Contains the preliminary (interstitial) work to the call to the radiation schemes: !! 1) Backs up the original qc & qi !! 2) Adds the partioning of convective condensate into liqice/ice for effective radii diff --git a/physics/module_SGSCloud_RadPre.meta b/physics/sgscloud_radpre.meta similarity index 100% rename from physics/module_SGSCloud_RadPre.meta rename to physics/sgscloud_radpre.meta diff --git a/physics/gcm_shoc.F90 b/physics/shoc.F90 similarity index 100% rename from physics/gcm_shoc.F90 rename to physics/shoc.F90 diff --git a/physics/gcm_shoc.meta b/physics/shoc.meta similarity index 100% rename from physics/gcm_shoc.meta rename to physics/shoc.meta diff --git a/physics/gscond.f b/physics/zhaocarr_gscond.f similarity index 100% rename from physics/gscond.f rename to physics/zhaocarr_gscond.f diff --git a/physics/gscond.meta b/physics/zhaocarr_gscond.meta similarity index 100% rename from physics/gscond.meta rename to physics/zhaocarr_gscond.meta diff --git a/physics/precpd.f b/physics/zhaocarr_precpd.f similarity index 100% rename from physics/precpd.f rename to physics/zhaocarr_precpd.f diff --git a/physics/precpd.meta b/physics/zhaocarr_precpd.meta similarity index 100% rename from physics/precpd.meta rename to physics/zhaocarr_precpd.meta From 8b4ee36339a23c2a0b3bca2afcde500adf2acd75 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Thu, 14 Apr 2022 14:40:46 +0000 Subject: [PATCH 166/217] "restore to gsl/develop" --- physics/GFS_DCNV_generic.F90 | 11 ++--------- physics/GFS_DCNV_generic.meta | 15 --------------- physics/GFS_SCNV_generic.F90 | 14 ++------------ physics/GFS_SCNV_generic.meta | 15 --------------- physics/GFS_suite_interstitial.F90 | 16 ++-------------- physics/GFS_suite_interstitial.meta | 15 --------------- 6 files changed, 6 insertions(+), 80 deletions(-) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index 4c5e7f717..e7dec5ca1 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -20,8 +20,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc save_u, save_v, save_t, save_q, clw, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & ntgnc, cscnv, satmedmf, trans_trac, ras, ntrac, & - dtidx, index_of_process_dcnv,rrfs_smoke,dqdti, & - errmsg, errflg) + dtidx, index_of_process_dcnv, errmsg, errflg) use machine, only: kind_phys @@ -29,7 +28,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc - logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm, rrfs_smoke + logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 @@ -38,8 +37,6 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc real(kind=kind_phys), dimension(:,:), intent(inout) :: save_v real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q - ! dqdti only allocated if rrfs_smoke is .true. - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg logical, intent(in) :: cscnv, satmedmf, trans_trac, ras @@ -91,10 +88,6 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc save_q(:,:,ntqv) = gq0(:,:,ntqv) endif - if (rrfs_smoke) then - dqdti = zero - endif - end subroutine GFS_DCNV_generic_pre_run end module GFS_DCNV_generic_pre diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index 1d7d87c17..47fb65d9a 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -247,21 +247,6 @@ dimensions = () type = integer intent = in -[rrfs_smoke] - standard_name = flag_for_rrfs_smoke_coupling - long_name = flag controlling rrfs_smoke collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_SCNV_generic.F90 b/physics/GFS_SCNV_generic.F90 index 45fc3dd2d..58447f6bf 100644 --- a/physics/GFS_SCNV_generic.F90 +++ b/physics/GFS_SCNV_generic.F90 @@ -99,7 +99,7 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & index_of_process_scnv, ntqv, flag_for_scnv_generic_tend, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & imfshalcnv, imfshalcnv_sas, imfshalcnv_samf, ntrac, & - cscnv, satmedmf, trans_trac, ras, rrfs_smoke, dqdti, errmsg, errflg) + cscnv, satmedmf, trans_trac, ras, errmsg, errflg) use machine, only: kind_phys @@ -107,14 +107,13 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & integer, intent(in) :: im, levs, nn, ntqv, nsamftrac integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac - logical, intent(in) :: lssav, ldiag3d, qdiag3d, flag_for_scnv_generic_tend, rrfs_smoke + logical, intent(in) :: lssav, ldiag3d, qdiag3d, flag_for_scnv_generic_tend real(kind=kind_phys), intent(in) :: frain real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 real(kind=kind_phys), dimension(:,:), intent(in) :: save_u, save_v, save_t real(kind=kind_phys), dimension(:,:,:), intent(in) :: save_q, gq0 ! dtend only allocated if ldiag3d == .true. - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti real(kind=kind_phys), intent(inout) :: dtend(:,:,:) integer, intent(in) :: dtidx(:,:) integer, intent(in) :: index_of_temperature, index_of_x_wind, index_of_y_wind, index_of_process_scnv @@ -210,15 +209,6 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & endif endif - if (rrfs_smoke) then - do k=1,levs - do i=1,im - tem = (gq0_water_vapor(i,k)-save_qv(i,k)) * frain - dqdti(i,k) = dqdti(i,k) + tem - enddo - enddo - endif - end subroutine GFS_SCNV_generic_post_run end module GFS_SCNV_generic_post diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index d1b4b452b..5cbda127c 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -663,21 +663,6 @@ dimensions = () type = integer intent = in -[rrfs_smoke] - standard_name = flag_for_rrfs_smoke_coupling - long_name = flag controlling rrfs_smoke collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 591e27d88..6963e94c3 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -701,7 +701,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & - qdiag3d, save_lnc, save_inc, ntk, ntke, rrfs_smoke, dqdti, errmsg, errflg) + qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) use machine, only: kind_phys use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber @@ -714,7 +714,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf - logical, intent(in) :: ltaerosol, convert_dry_rho, rrfs_smoke + logical, intent(in) :: ltaerosol, convert_dry_rho real(kind=kind_phys), intent(in ) :: con_pi, dtf real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc @@ -734,9 +734,6 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp real(kind=kind_phys), dimension(:,:), intent(in) :: spechum - ! dqdti may not be allocated - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti - character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -922,15 +919,6 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo endif ! end if_ntcw -! dqdt_v : instaneous moisture tendency (kg/kg/sec) - if (rrfs_smoke) then - do k=1,levs - do i=1,im - dqdti(i,k) = dqdti(i,k) * (1.0 / dtf) - enddo - enddo - endif - end subroutine GFS_suite_interstitial_4_run end module GFS_suite_interstitial_4 diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index c994f1363..43b3d5efa 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1808,21 +1808,6 @@ dimensions = () type = integer intent = in -[rrfs_smoke] - standard_name = flag_for_rrfs_smoke_coupling - long_name = flag controlling rrfs_smoke collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From b6a03c8c23d903dcaaf379cce9c2f46c9d4ed95a Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 14 Apr 2022 11:49:58 -0400 Subject: [PATCH 167/217] update filename in CMakeLists.txt --- CMakeLists.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 17ccabebc..60531b9a5 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -120,8 +120,8 @@ set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_ # List of files that need to be compiled with different precision set(SCHEMES_DYNAMICS) -if(${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 IN_LIST SCHEMES) - list(APPEND SCHEMES_DYNAMICS ${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90) +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) endif() # Remove files that need to be compiled with different precision From 5b3adf34becaf47fb9b0ae65b2a0c3871189ecde Mon Sep 17 00:00:00 2001 From: "Chunxi.Zhang-NOAA" Date: Thu, 14 Apr 2022 20:54:19 +0000 Subject: [PATCH 168/217] A bug fix in mass flux divergence computation for wet scavenging of aerosols and a minor modification in moisture property calculation for the saSAS cumulus scheme --- physics/samfdeepcnv.f | 58 ++++++++++++++++--------------------------- physics/samfshalcnv.f | 24 +++++++++--------- 2 files changed, 33 insertions(+), 49 deletions(-) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index ea92fda7f..bb33b20cf 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -265,7 +265,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & dellae(im,km,ntr), & dellau(im,km), dellav(im,km), hcko(im,km), & ucko(im,km), vcko(im,km), qcko(im,km), - & ecko(im,km,ntr), + & ecko(im,km,ntr),ercko(im,km,ntr), & eta(im,km), etad(im,km), zi(im,km), & qrcko(im,km), qrcdo(im,km), & pwo(im,km), pwdo(im,km), c0t(im,km), @@ -585,6 +585,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ctr(i,k,kk) = qtr(i,k,n) ctro(i,k,kk) = qtr(i,k,n) ecko(i,k,kk) = 0. + ercko(i,k,kk) = 0. ecdo(i,k,kk) = 0. endif enddo @@ -1148,6 +1149,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(cnvflg(i)) then indx = kb(i) ecko(i,indx,n) = ctro(i,indx,n) + ercko(i,indx,n) = ctro(i,indx,n) endif enddo enddo @@ -1199,6 +1201,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & factor = 1. + tem ecko(i,k,n) = ((1.-tem)*ecko(i,k-1,n)+tem* & (ctro(i,k,n)+ctro(i,k-1,n)))/factor + ercko(i,k,n) = ecko(i,k,n) endif endif enddo @@ -1217,6 +1220,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & factor = 1. + tem ecko(i,k,kk) = ((1. - tem) * ecko(i,k-1,kk) + tem * & (ctro(i,k,kk) + ctro(i,k-1,kk))) / factor + ercko(i,k,kk) = ecko(i,k,kk) chem_c(i,k,n) = fscav(n) * ecko(i,k,kk) tem = chem_c(i,k,n) / (1. + c0t(i,k) * dz) chem_pw(i,k,n) = c0t(i,k) * dz * tem * eta(i,k-1) @@ -1464,12 +1468,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & qrch = qeso(i,k) & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz tem = cq * tem - tem1 = cq * tem1 - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + factor = 1. + tem + qcko(i,k) = ((1.-tem)*qcko(i,k-1)+tem* & (qo(i,k)+qo(i,k-1)))/factor qrcko(i,k) = qcko(i,k) cj @@ -1641,12 +1643,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & qrch = qeso(i,k) & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz tem = cq * tem - tem1 = cq * tem1 - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + factor = 1. + tem + qcko(i,k) = ((1.-tem)*qcko(i,k-1)+tem* & (qo(i,k)+qo(i,k-1)))/factor qrcko(i,k) = qcko(i,k) cj @@ -1955,17 +1955,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! detad = etad(i,k+1) - etad(i,k) cj dz = zi(i,k+1) - zi(i,k) - if(k >= kd94(i)) then - tem = xlamde * dz - tem1 = 0.5 * xlamdd * dz - else - tem = xlamde * dz - tem1 = 0.5 * (xlamd(i)+xlamdd) * dz - endif + tem = 0.5 * xlamde * dz tem = cq * tem - tem1 = cq * tem1 - factor = 1. + tem - tem1 - qcdo(i,k) = ((1.-tem1)*qrcdo(i,k+1)+tem*0.5* + factor = 1. + tem + qcdo(i,k) = ((1.-tem)*qrcdo(i,k+1)+tem* & (qo(i,k)+qo(i,k+1)))/factor cj ! pwdo(i,k) = etad(i,k+1) * qcdo(i,k+1) - @@ -2153,7 +2146,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(k > jmin(i)) adw = 0. dp = 1000. * del(i,k) cj - tem1 = -eta(i,k) * ecko(i,k,n) + tem1 = -eta(i,k) * ercko(i,k,n) tem2 = -eta(i,k-1) * ecko(i,k-1,n) ptem1 = -etad(i,k) * ecdo(i,k,n) ptem2 = -etad(i,k-1) * ecdo(i,k-1,n) @@ -2512,12 +2505,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & xqrch = qeso(i,k) & + gamma * xdby / (hvap * (1. + gamma)) cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz tem = cq * tem - tem1 = cq * tem1 - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + factor = 1. + tem + qcko(i,k) = ((1.-tem)*qcko(i,k-1)+tem* & (qo(i,k)+qo(i,k-1)))/factor cj dq = eta(i,k) * (qcko(i,k) - xqrch) @@ -2603,17 +2594,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! detad = etad(i,k+1) - etad(i,k) cj dz = zi(i,k+1) - zi(i,k) - if(k >= kd94(i)) then - tem = xlamde * dz - tem1 = 0.5 * xlamdd * dz - else - tem = xlamde * dz - tem1 = 0.5 * (xlamd(i)+xlamdd) * dz - endif + tem = 0.5 * xlamde * dz tem = cq * tem - tem1 = cq * tem1 - factor = 1. + tem - tem1 - qcdo(i,k) = ((1.-tem1)*qrcd(i,k+1)+tem*0.5* + factor = 1. + tem + qcdo(i,k) = ((1.-tem)*qrcd(i,k+1)+tem* & (qo(i,k)+qo(i,k+1)))/factor cj ! xpwd = etad(i,k+1) * qcdo(i,k+1) - diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 24e01b040..364049e4d 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -213,7 +213,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & dellau(im,km), dellav(im,km), hcko(im,km), & ucko(im,km), vcko(im,km), qcko(im,km), & qrcko(im,km), ecko(im,km,ntr), - & eta(im,km), + & ercko(im,km,ntr), eta(im,km), & zi(im,km), pwo(im,km), c0t(im,km), & sumx(im), tx1(im), cnvwt(im,km) &, rhbar(im) @@ -510,6 +510,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ctr(i,k,kk) = qtr(i,k,n) ctro(i,k,kk) = qtr(i,k,n) ecko(i,k,kk) = 0. + ercko(i,k,kk) = 0. endif enddo enddo @@ -964,6 +965,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(cnvflg(i)) then indx = kb(i) ecko(i,indx,n) = ctro(i,indx,n) + ercko(i,indx,n) = ctro(i,indx,n) endif enddo enddo @@ -1014,6 +1016,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & factor = 1. + tem ecko(i,k,n) = ((1.-tem)*ecko(i,k-1,n)+tem* & (ctro(i,k,n)+ctro(i,k-1,n)))/factor + ercko(i,k,n) = ecko(i,k,n) endif endif enddo @@ -1032,6 +1035,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & factor = 1. + tem ecko(i,k,kk) = ((1. - tem) * ecko(i,k-1,kk) + tem * & (ctro(i,k,kk) + ctro(i,k-1,kk))) / factor + ercko(i,k,kk) = ecko(i,k,kk) chem_c(i,k,n) = escav * fscav(n) * ecko(i,k,kk) tem = chem_c(i,k,n) / (1. + c0t(i,k) * dz) chem_pw(i,k,n) = c0t(i,k) * dz * tem * eta(i,k-1) @@ -1208,12 +1212,10 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qrch = qeso(i,k) & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz tem = cq * tem - tem1 = cq * tem1 - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + factor = 1. + tem + qcko(i,k) = ((1.-tem)*qcko(i,k-1)+tem* & (qo(i,k)+qo(i,k-1)))/factor qrcko(i,k) = qcko(i,k) cj @@ -1376,12 +1378,10 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qrch = qeso(i,k) & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz tem = cq * tem - tem1 = cq * tem1 - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + factor = 1. + tem + qcko(i,k) = ((1.-tem)*qcko(i,k-1)+tem* & (qo(i,k)+qo(i,k-1)))/factor qrcko(i,k) = qcko(i,k) cj @@ -1621,7 +1621,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(k > kb(i) .and. k < ktcon(i)) then dp = 1000. * del(i,k) cj - tem1 = -eta(i,k) * ecko(i,k,n) + tem1 = -eta(i,k) * ercko(i,k,n) tem2 = -eta(i,k-1) * ecko(i,k-1,n) dellae(i,k,n) = dellae(i,k,n) + (tem1-tem2) * grav/dp cj From 842eae33944aafb5100ccb7660a04027a7452147 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Mon, 18 Apr 2022 15:05:40 +0000 Subject: [PATCH 169/217] Ensuring the moisture budget is correct via PBL, microphysics coupling --- physics/GFS_MP_generic.F90 | 26 +++++-- physics/GFS_MP_generic.meta | 23 ++++++ physics/progsigma_calc.f90 | 33 +------- physics/samfdeepcnv.f | 149 +++++++++++++++++++++++++++++++----- physics/samfdeepcnv.meta | 86 ++++++++++++++++++++- physics/satmedmfvdifq.F | 5 +- physics/satmedmfvdifq.meta | 8 ++ 7 files changed, 274 insertions(+), 56 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index e106cb908..dbf2d15fa 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -88,14 +88,15 @@ end subroutine GFS_MP_generic_post_init !> @{ 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, con_g, rainmin, dtf, frain, rainc, & + imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, progsigma, con_g, rainmin, dtf, frain, rainc, & rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, 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, & drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & - dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d, lssav, num_dfi_radar, fh_dfi_radar, & - index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, errmsg, errflg) + dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & + fh_dfi_radar,index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, qgrs_dsave, & + errmsg, errflg) ! use machine, only: kind_phys @@ -104,7 +105,7 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac, num_dfi_radar, index_of_process_dfi_radar integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm + logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, progsigma integer, intent(in) :: index_of_temperature,index_of_process_mp integer :: dfi_radar_max_intervals @@ -148,7 +149,8 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), dimension(:), intent(inout) :: diceprv real(kind=kind_phys), dimension(:), intent(inout) :: dsnowprv real(kind=kind_phys), dimension(:), intent(inout) :: dgraupelprv - + real(kind=kind_phys), dimension(:,:), intent(out) :: dqdt_qmicro + real(kind=kind_phys), dimension(:,:), intent(out) :: qgrs_dsave real(kind=kind_phys), intent(in) :: dtp ! CCPP error handling @@ -420,6 +422,15 @@ subroutine GFS_MP_generic_post_run( endif if_tendency_diagnostics endif if_save_fields + !If prognostic updraft area fraction is used in saSAS + if(progsigma)then + do k=1,levs + do i=1,im + dqdt_qmicro(i,k)=(gq0(i,k,1)-save_q(i,k,1))/dtp + enddo + enddo + endif + if (cplflx .or. cplchm) then do i = 1, im dsnow_cpl(i)= max(zero, rain(i) * srflag(i)) @@ -455,6 +466,11 @@ subroutine GFS_MP_generic_post_run( pwat(i) = pwat(i) * onebg enddo + do k = 1, levs + do i=1, im + qgrs_dsave(i,k) = gq0(i,k,1) + enddo + enddo end subroutine GFS_MP_generic_post_run !> @} diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index 6177b1344..f8cb0acae 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -248,6 +248,13 @@ dimensions = () type = logical intent = in +[progsigma] + standard_name = flag_for_prognostic_sigma + long_name = flag for prognostic sigma + units = flag + dimensions = () + type = logical + intent = in [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -844,6 +851,22 @@ dimensions = () type = logical intent = in +[dqdt_qmicro] + standard_name = instantanious_moisture_tendency_due_to_microphysics + long_name = moisture tendency due to microphysics + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[qgrs_dsave] + standard_name = tracer_concentration_dsave + long_name = model layer mean tracer concentration dsave + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [lssav] standard_name = flag_for_diagnostics long_name = logical flag for storing diagnostics diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index 378d43ef4..6772bc8d4 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -12,12 +12,11 @@ !!\section progsigma General Algorithm !> @{ - subroutine progsigma_calc (im,km,flag_init,flag_restart,flag_deep, & + subroutine progsigma_calc (im,km,flag_init,flag_restart, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, & qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, & do_ca, ca_closure, ca_entr, ca_trigger, nthresh, ca_deep, & - ca_turb,ca_micro,ca_shal,ca_rad,convcount,ca1,ca2,ca3,ca4, & - sigmain,sigmaout,sigmab,errmsg,errflg) + ca_micro,sigmain,sigmaout,sigmab,errmsg,errflg) ! ! use machine, only : kind_phys @@ -31,12 +30,10 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart,flag_deep, & real, intent(in) :: qgrs_dsave(im,km), q(im,km),del(im,km), & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & omega_u(im,km),zeta(im,km),gdx(im) - logical, intent(in) :: flag_init,flag_restart,flag_deep,cnvflg(im) + logical, intent(in) :: flag_init,flag_restart,cnvflg(im) real(kind=kind_phys), intent(in) :: nthresh real(kind=kind_phys), intent(in) :: ca_deep(im) - real(kind=kind_phys), intent(out):: ca_turb(im), & - ca_micro(im),ca_rad(im),ca_shal(im),convcount(im),ca1(im), & - ca2(im),ca3(im),ca4(im) + real(kind=kind_phys), intent(out):: ca_micro(im) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger real(kind=kind_phys), intent(in) :: sigmain(im,km) @@ -87,19 +84,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart,flag_deep, & mcons(i)=0. enddo - !Temporary Initialization output: - do i = 1,im - if(flag_deep)then - !ca_turb(i)=0. - ca_shal(i)=0. - endif - if(.not. flag_deep)then - ca_rad(i)=0. - convcount(i)=0. - ca1(i)=0. - endif - enddo - !Initial computations, place maximum sigmain in sigmab do k=2,km @@ -232,15 +216,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart,flag_deep, & sigmab(i)=MAX(sigmab(i),0.01) endif - if(flag_deep)then - !ca_turb(i)=ZCVG - ca_shal(i)=termC(i) - else - ca_rad(i)=ZCVG - ca1(i)=termC(i) - endif - !ca3(i)=sigmab(i) - endif!cnvflg enddo diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index ea92fda7f..7be31a04a 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -75,17 +75,18 @@ end subroutine samfdeepcnv_finalize !! !! \section samfdeep_detailed GFS samfdeepcnv Detailed Algorithm !! @{ - subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & + subroutine samfdeepcnv_run (im,km,first_time_step,restart, & + & tmf,qmicro,itc,ntc,cliq,cp,cvap, & & eps,epsm1,fv,grav,hvap,rd,rv, & & t0c,delt,ntk,ntr,delp, & - & prslp,psp,phil,qtr,q1,t1,u1,v1,fscav,hwrf_samfdeep, & - & cldwrk,rn,kbot,ktop,kcnv,islimsk,garea, & - & dot,ncloud,hpbl,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & + & prslp,psp,phil,qtr,qgrs_dsave,q,q1,t1,u1,v1,fscav, & + & hwrf_samfdeep,progsigma,wclosureflg,cldwrk,rn,kbot,ktop,kcnv, & + & islimsk,garea,dot,ncloud,hpbl,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & & QLCN, QICN, w_upi, cf_upi, CNV_MFD, & & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys,mp_phys_mg,& & clam,c0s,c1,betal,betas,evef,pgcon,asolfac, & & do_ca, ca_closure, ca_entr, ca_trigger, nthresh, ca_deep, & - & rainevap, & + & rainevap, sigmain, sigmaout, ca_micro, & & errmsg,errflg) ! use machine , only : kind_phys @@ -101,10 +102,14 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:) real(kind=kind_phys), dimension(:), intent(in) :: fscav - logical, intent(in) :: hwrf_samfdeep + logical, intent(in) :: first_time_step,restart,hwrf_samfdeep, & + & progsigma, wclosureflg real(kind=kind_phys), intent(in) :: nthresh real(kind=kind_phys), intent(in) :: ca_deep(:) - real(kind=kind_phys), intent(out) :: rainevap(:) + real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & + & tmf(:,:),q(:,:), qgrs_dsave(:,:) + real(kind=kind_phys), intent(out) :: rainevap(:),ca_micro(:) + real(kind=kind_phys), intent(out) :: sigmaout(:,:) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger integer, intent(inout) :: kcnv(:) @@ -208,6 +213,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! & bb1, bb2 & bb1, bb2, wucb ! +! parameters for prognostic sigma closure + real(kind=kind_phys) omega_u(im,km),zdqca(im,km),qlks(im,km), + & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im) + c physical parameters ! parameter(grav=grav,asolfac=0.958) ! parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) @@ -368,6 +377,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & vshear(i) = 0. advfac(i) = 0. rainevap(i) = 0. + omegac(i)=0. gdx(i) = sqrt(garea(i)) enddo @@ -570,6 +580,11 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & buo(i,k) = 0. drag(i,k) = 0. cnvwt(i,k)= 0. + dbyo1(i,k)=0. + zdqca(i,k)=0. + qlks(i,k)=0. + omega_u(i,k)=0. + zeta(i,k)=1.0 endif enddo enddo @@ -1497,6 +1512,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp + qlks(i,k)=qlk endif ! ! compute buoyancy and drag for updraft velocity @@ -1569,6 +1585,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & dz1 = zo(i,k+1) - zo(i,k) ! aa1(i) = aa1(i) + buo(i,k) * dz1 * eta(i,k) aa1(i) = aa1(i) + buo(i,k) * dz1 + dbyo1(i,k) = hcko(i,k) - heso(i,k) endif endif enddo @@ -1669,6 +1686,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp + qlks(i,k)=qlk endif endif endif @@ -1710,6 +1728,20 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif enddo enddo + + if(progsigma)then + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + rho = po(i,k)*100. / (rd * to(i,k)) + omega_u(i,k)=-1.0*sqrt(wu2(i,k))*rho*grav + omega_u(i,k)=MAX(omega_u(i,k),-80.) + endif + endif + enddo + enddo + endif ! ! compute updraft velocity average over the whole cumulus ! @@ -1742,6 +1774,54 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif enddo c + +!> - Calculate the mean updraft velocity within the cloud (wc),cast in pressure coordinates. + if(progsigma)then + + do i = 1, im + omegac(i) = 0. + sumx(i) = 0. + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + dp = 1000. * del(i,k) + tem = 0.5 * (omega_u(i,k) + omega_u(i,k-1)) + omegac(i) = omegac(i) + tem * dp + sumx(i) = sumx(i) + dp + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + if(sumx(i) == 0.) then + cnvflg(i)=.false. + else + omegac(i) = omegac(i) / sumx(i) + endif + val = -1.2 + if (omegac(i) > val) cnvflg(i)=.false. + endif + enddo + +!> - Calculate the xi term in Bengtsson et al. 2022 (equation 8) + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= kbcon1(i) .and. k < ktcon(i)) then + zeta(i,k)=eta(i,k)*(omegac(i)/omega_u(i,k)) + zeta(i,k)=MAX(0.,zeta(i,k)) + zeta(i,k)=MIN(1.,zeta(i,k)) + endif + endif + enddo + enddo + + + endif !if progsigma + c exchange ktcon with ktcon1 c !> - Swap the indices of the convective cloud top (ktcon) and the overshooting convection top (ktcon1) to use the same cloud top level in the calculations of \f$A^+\f$ and \f$A^*\f$. @@ -1773,11 +1853,26 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(dq > 0.) then qlko_ktcon(i) = dq qcko(i,k) = qrch + qlks(i,k) = qlko_ktcon(i) endif endif enddo endif c + +c store term needed for "termC" in prognostic area fraction closure + do k = 2, km1 + do i = 1, im + dp = 1000. * del(i,k) + if (cnvflg(i)) then + if(k > kbcon(i) .and. k < ktcon(i)) then + zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + + & pwo(i,k)+dellal(i,k)) + endif + endif + enddo + enddo + ccccc if(lat.==.latd.and.lon.==.lond.and.cnvflg(i)) then ccccc print *, ' aa1(i) before dwndrft =', aa1(i) ccccc endif @@ -2375,6 +2470,14 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & asqecflg(i) = .false. endif enddo + +!> - If wclosureflg is true, then quasi-equilibrium closure of Arakawa-Schubert is not used any longer, regardless of resolution + if(wclosureflg)then + do i = 1, im + asqecflg(i) = .false. + enddo + endif + ! !> - If grid size is larger than the threshold value (i.e., asqecflg=.true.), the quasi-equilibrium assumption is used to obtain the cloud base mass flux. To begin with, calculate the change in the temperature and moisture profiles per unit cloud base mass flux. do k = 1, km @@ -2784,13 +2887,27 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & advfac(i) = min(advfac(i), 1.) endif enddo + +!> - From Bengtsson et al. (2022) Prognostic closure scheme, equation 8, compute updraft area fraction based on a moisture budget + if(progsigma)then + call progsigma_calc(im,km,first_time_step,restart, + & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, + & qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, + & do_ca, ca_closure, ca_entr, ca_trigger, nthresh, ca_deep, + & ca_micro,sigmain,sigmaout,sigmab,errmsg,errflg) + 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. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. do i= 1, im if(cnvflg(i) .and. .not.asqecflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) - xmb(i) = advfac(i)*betaw*rho*wc(i) + if(progsigma)then + xmb(i) = sigmab(i)*((-1.0*omegac(i))/grav) + else + xmb(i) = advfac(i)*betaw*rho*wc(i) + endif endif enddo !> - For the cases where the quasi-equilibrium assumption of Arakawa-Schubert is valid, first calculate the large scale destabilization as in equation 5 of Pan and Wu (1995) \cite pan_and_wu_1995 : @@ -2859,7 +2976,11 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im if(cnvflg(i)) then if (gdx(i) < dxcrtuf) then - scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) + if(progsigma)then + scaldfunc(i)=(1.-sigmab(i))*(1.-sigmab(i)) + else + scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) + endif scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) else scaldfunc(i) = 1.0 @@ -2869,16 +2990,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif enddo ! - if (do_ca .and. ca_closure)then - do i = 1, im - if(cnvflg(i)) then - if (ca_deep(i) > nthresh) then - xmb(i) = xmb(i)*1.25 - endif - endif - enddo - endif - !> - Transport aerosols if present ! ! if (do_aerosols) diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index baf01fb8e..3eb330551 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = samfdeepcnv type = scheme - dependencies = funcphys.f90,machine.F,samfaerosols.F + dependencies = funcphys.f90,machine.F,samfaerosols.F,progsigma_calc.f90 ######################################################################## [ccpp-arg-table] @@ -55,6 +55,36 @@ dimensions = () type = integer intent = in +[first_time_step] + standard_name = flag_for_first_timestep + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[tmf] + standard_name = turbulence_moisture_flux + long_name = turbulence_moisture_flux + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qmicro] + standard_name = instantanious_moisture_tendency_due_to_microphysics + long_name = moisture tendency due to microphysics + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [itc] standard_name = index_of_first_chemical_tracer_for_convection long_name = index of first chemical tracer transported/scavenged by convection @@ -219,6 +249,22 @@ type = real kind = kind_phys intent = inout +[qgrs_dsave] + standard_name = tracer_concentration_dsave + long_name = model layer mean tracer concentration dsave + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[q] + standard_name = specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [q1] standard_name = specific_humidity_of_new_state long_name = updated vapor specific humidity @@ -266,6 +312,28 @@ dimensions = () type = logical intent = in +[wclosureflg] + standard_name = flag_for_wclosure + long_name = flag for vertical velocity closure + units = flag + dimensions = () + type = logical + intent = in +[progsigma] + standard_name = flag_for_prognostic_sigma + long_name = flag for prognostic sigma + units = flag + dimensions = () + type = logical + intent = in +[ca_micro] + standard_name = output_prognostic_sigma_two + long_name = output of prognostic area fraction two + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [cldwrk] standard_name = cloud_work_function long_name = cloud work function @@ -381,6 +449,22 @@ type = real kind = kind_phys intent = inout +[sigmain] + standard_name = updraft_area_fraction + long_name = convective updraft area fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[sigmaout] + standard_name = updraft_area_fraction_updated_by_physics + long_name = convective updraft area fraction updated by physics + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [qlcn] standard_name = mass_fraction_of_convective_cloud_liquid_water long_name = mass fraction of convective cloud liquid water diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index eb2b7ad1c..b0367b4d4 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -69,7 +69,7 @@ end subroutine satmedmfvdifq_finalize !! @{ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & & grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea,zvfun, & + & dv,du,tdt,rtg,tmf,u1,v1,t1,q1,swh,hlw,xmu,garea,zvfun, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & & prsi,del,prsl,prslk,phii,phil,delt, & @@ -121,7 +121,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & real(kind=kind_phys), intent(out) :: & & dusfc(:), dvsfc(:), & & dtsfc(:), dqsfc(:), & - & hpbl(:) + & hpbl(:), tmf(:,:) real(kind=kind_phys), intent(out) :: & & dkt(:,:), dku(:,:) ! @@ -2114,6 +2114,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & qtend = (f2(i,k)-q1(i,k,1))*rdt tdt(i,k) = tdt(i,k)+ttend rtg(i,k,1) = rtg(i,k,1)+qtend + tmf(i,k) = qtend ! dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend ! dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend enddo diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index db89f488d..211bbaec6 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -201,6 +201,14 @@ type = real kind = kind_phys intent = inout +[tmf] + standard_name = turbulence_moisture_flux + long_name = turbulence_moisture_flux + units = kg kg-1 s-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [u1] standard_name = x_wind long_name = x component of layer wind From 4f84ed749af88d8d833d78ec352c2a02dfb52589 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Tue, 19 Apr 2022 19:22:53 +0000 Subject: [PATCH 170/217] add shallow convection closure updates, add ntsigma in generic files --- physics/GFS_DCNV_generic.F90 | 14 ++-- physics/GFS_DCNV_generic.meta | 14 ++++ physics/GFS_MP_generic.meta | 2 +- physics/GFS_SCNV_generic.F90 | 12 +-- physics/GFS_SCNV_generic.meta | 14 ++++ physics/progsigma_calc.f90 | 73 +++++++++--------- physics/samfdeepcnv.f | 31 ++++---- physics/samfdeepcnv.meta | 10 +-- physics/samfshalcnv.f | 139 +++++++++++++++++++++++++++++++--- physics/samfshalcnv.meta | 79 ++++++++++++++++++- physics/satmedmfvdifq.F | 5 +- physics/satmedmfvdifq.meta | 6 +- 12 files changed, 315 insertions(+), 84 deletions(-) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index a9e0ba7e0..07defcba1 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -18,8 +18,8 @@ end subroutine GFS_DCNV_generic_pre_finalize subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplchm, & gu0, gv0, gt0, gq0, nsamftrac, ntqv, & save_u, save_v, save_t, save_q, clw, & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv, & + ntcw,ntiw,ntclamt,ntsigma,ntrw,ntsw,ntrnc,ntsnc,& + ntgl,ntgnc, nthl, nthnc, nthv, ntgv, & cscnv, satmedmf, trans_trac, ras, ntrac, & dtidx, index_of_process_dcnv, errmsg, errflg) @@ -28,7 +28,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc implicit none integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv,ntsigma logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 @@ -74,7 +74,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & n /= nthl .and. n /= nthnc .and. n /= nthv .and. & - n /= ntgv ) then + n /= ntgv .and. n /= ntsigma) then tracers = tracers + 1 if(dtidx(100+n,index_of_process_dcnv)>0) then save_q(:,:,n) = clw(:,:,tracers) @@ -114,7 +114,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & rainc, cldwrk, upd_mf, dwn_mf, det_mf, dtend, dtidx, index_of_process_dcnv, & index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv, gq0, save_q, & cnvw, cnvc, cnvw_phy_f3d, cnvc_phy_f3d, flag_for_dcnv_generic_tend, & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & + ntcw,ntiw,ntclamt,ntsigma,ntrw,ntsw,ntrnc,ntsnc,ntgl, & ntgnc, nthl, nthnc, nthv, ntgv, ntrac,clw, & satmedmf, trans_trac, errmsg, errflg) @@ -145,7 +145,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & integer, intent(in) :: dtidx(:,:), index_of_process_dcnv, index_of_temperature, & index_of_x_wind, index_of_y_wind, ntqv integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv, ntrac + ntgnc, nthl, nthnc, nthv, ntgv, ntsigma, ntrac real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw @@ -212,7 +212,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & n /= nthl .and. n /= nthnc .and. n /= nthv .and. & - n /= ntgv ) then + n /= ntgv .and. n /= ntsigma) then tracers = tracers + 1 idtend = dtidx(100+n,index_of_process_dcnv) if(idtend>0) then diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index e15acaf1c..f095259d4 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -190,6 +190,13 @@ dimensions = () type = integer intent = in +[ntsigma] + standard_name = index_of_updraft_area_fraction_in_tracer_concentration_array + long_name = tracer index of updraft_area_fraction + units = index + dimensions = () + type = integer + intent = in [ntrw] standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array long_name = tracer index for rain water @@ -670,6 +677,13 @@ dimensions = () type = integer intent = in +[ntsigma] + standard_name = index_of_updraft_area_fraction_in_tracer_concentration_array + long_name = tracer index of updraft_area_fraction + units = index + dimensions = () + type = integer + intent = in [ntrw] standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array long_name = tracer index for rain water diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index f8cb0acae..763cad85a 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -852,7 +852,7 @@ type = logical intent = in [dqdt_qmicro] - standard_name = instantanious_moisture_tendency_due_to_microphysics + standard_name = instantaneous_moisture_tendency_due_to_microphysics long_name = moisture tendency due to microphysics units = kg kg-1 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/physics/GFS_SCNV_generic.F90 b/physics/GFS_SCNV_generic.F90 index 58447f6bf..cbef02bb0 100644 --- a/physics/GFS_SCNV_generic.F90 +++ b/physics/GFS_SCNV_generic.F90 @@ -17,14 +17,14 @@ end subroutine GFS_SCNV_generic_pre_finalize subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, gu0, gv0, gt0, gq0, & save_u, save_v, save_t, save_q, ntqv, nsamftrac, flag_for_scnv_generic_tend, & dtidx, index_of_process_scnv, ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & - cscnv, satmedmf, trans_trac, ras, ntrac, clw, errmsg, errflg) + ntsigma, cscnv, satmedmf, trans_trac, ras, ntrac, clw, errmsg, errflg) use machine, only: kind_phys implicit none integer, intent(in) :: im, levs, ntqv, nsamftrac, index_of_process_scnv, dtidx(:,:) - integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac + integer, intent(in) :: ntcw,ntiw,ntclamt,ntsigma,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac logical, intent(in) :: ldiag3d, qdiag3d, flag_for_scnv_generic_tend real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0 @@ -55,7 +55,7 @@ subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, gu0, gv0, gt0, do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. n /= ntsigma) then tracers = tracers + 1 if(dtidx(100+n,index_of_process_scnv)>0) then save_q(:,:,n) = clw(:,:,tracers) @@ -97,7 +97,7 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & rainc, cnvprcp, cnvprcpb, cnvw_phy_f3d, cnvc_phy_f3d, & dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & index_of_process_scnv, ntqv, flag_for_scnv_generic_tend, & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & + ntcw,ntiw,ntclamt,ntsigma,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & imfshalcnv, imfshalcnv_sas, imfshalcnv_samf, ntrac, & cscnv, satmedmf, trans_trac, ras, errmsg, errflg) @@ -106,7 +106,7 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & implicit none integer, intent(in) :: im, levs, nn, ntqv, nsamftrac - integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac + integer, intent(in) :: ntcw,ntiw,ntclamt,ntsigma,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac logical, intent(in) :: lssav, ldiag3d, qdiag3d, flag_for_scnv_generic_tend real(kind=kind_phys), intent(in) :: frain real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 @@ -186,7 +186,7 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. n/= ntsigma) then tracers = tracers + 1 idtend = dtidx(100+n,index_of_process_scnv) if(idtend>0) then diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index 5cbda127c..4fd189948 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -183,6 +183,13 @@ dimensions = () type = integer intent = in +[ntsigma] + standard_name = index_of_updraft_area_fraction_in_tracer_concentration_array + long_name = tracer index of updraft_area_fraction + units = index + dimensions = () + type = integer + intent = in [ntrw] standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array long_name = tracer index for rain water @@ -614,6 +621,13 @@ dimensions = () type = integer intent = in +[ntsigma] + standard_name = index_of_updraft_area_fraction_in_tracer_concentration_array + long_name = tracer index of updraft_area_fraction + units = index + dimensions = () + type = integer + intent = in [ntrw] standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array long_name = tracer index for rain water diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index 6772bc8d4..ca05f6778 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -1,7 +1,8 @@ !>\file progsigma !! This file contains the subroutine that calculates the prognostic !! updraft area fraction that is used for closure computations in -!! saSAS deep and shallow convection. +!! saSAS deep and shallow convection, based on a moisture budget +!! as described in Bengtsson et al. 2022. !>\ingroup samfdeepcnv !! This subroutine computes a prognostic updraft area fraction @@ -13,9 +14,8 @@ !> @{ subroutine progsigma_calc (im,km,flag_init,flag_restart, & - del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, & - qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, & - do_ca, ca_closure, ca_entr, ca_trigger, nthresh, ca_deep, & + flag_shallow,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & + delt,qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, & ca_micro,sigmain,sigmaout,sigmab,errmsg,errflg) ! ! @@ -30,12 +30,8 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & real, intent(in) :: qgrs_dsave(im,km), q(im,km),del(im,km), & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & omega_u(im,km),zeta(im,km),gdx(im) - logical, intent(in) :: flag_init,flag_restart,cnvflg(im) - real(kind=kind_phys), intent(in) :: nthresh - real(kind=kind_phys), intent(in) :: ca_deep(im) + logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow real(kind=kind_phys), intent(out):: ca_micro(im) - logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger - real(kind=kind_phys), intent(in) :: sigmain(im,km) ! intent out @@ -47,28 +43,29 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! Local variables integer :: i,k,km1 real(kind=kind_phys) :: termA(im),termB(im),termC(im),termD(im), & - mcons(im),zfdqa(im),zform(im,km), & + mcons(im),fdqa(im),form(im,km), & qadv(im,km),sigmamax(im) - real(kind=kind_phys) :: gcvalmx,ZEPS7,ZZ,ZCVG,mcon,buy2, & - zfdqb,dtdyn,dxlim,rmulacvg,dp,tem, & - alpha,DEN + real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, & + fdqb,dtdyn,dxlim,rmulacvg,dp,tem, & + alpha,DEN,betascu integer :: inbu(im,km) !Parameters gcvalmx = 0.1 rmulacvg=10. - ZEPS7=1.E-11 + epsilon=1.E-11 km1=km-1 alpha=7000. + betascu = 3.0 !Initialization 2D do k = 1,km do i = 1,im sigmaout(i,k)=0. inbu(i,k)=0 - zform(i,k)=0. + form(i,k)=0. enddo enddo @@ -80,8 +77,9 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & termB(i)=0. termC(i)=0. termD(i)=0. - zfdqa(i)=0. + fdqa(i)=0. mcons(i)=0. + ca_micro(i)=0. enddo !Initial computations, place maximum sigmain in sigmab @@ -94,9 +92,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & endif else if(cnvflg(i))then - !if(sigmain(i,k)<1.E-5)then - ! sigmain(i,k)=0. - !endif if(sigmain(i,k)>sigmab(i))then sigmab(i)=sigmain(i,k) endif @@ -107,7 +102,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do i=1,im if(sigmab(i) < 1.E-5)then !after advection - sigmab(i)=0. + sigmab(i)=0. endif enddo @@ -180,11 +175,11 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do i = 1,im if(cnvflg(i))then dp = 1000. * del(i,k) - zform(i,k)=-1.0*float(inbu(i,k))*(omega_u(i,k)*delt) - zfdqb=0.5*((zform(i,k)*zdqca(i,k))) + form(i,k)=-1.0*float(inbu(i,k))*(omega_u(i,k)*delt) + fdqb=0.5*((form(i,k)*zdqca(i,k))) termC(i)=termC(i)+(float(inbu(i,k))* & - (zfdqb+zfdqa(i))*hvap*zeta(i,k)) - zfdqa(i)=zfdqb + (fdqb+fdqa(i))*hvap*zeta(i,k)) + fdqa(i)=fdqb endif enddo enddo @@ -193,29 +188,26 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do i = 1,im if(cnvflg(i))then - DEN=MIN(termC(i)+termB(i),1.E8) !1.E8 - !DEN=MAX(termC(i)+termB(i),1.E7) !1.E7 - - ZCVG=termD(i)*delt - + DEN=MIN(termC(i)+termB(i),1.E8) + cvg=termD(i)*delt ZZ=MAX(0.0,SIGN(1.0,termA(i))) & *MAX(0.0,SIGN(1.0,termB(i))) & - *MAX(0.0,SIGN(1.0,termC(i)-ZEPS7)) + *MAX(0.0,SIGN(1.0,termC(i)-epsilon)) - ZCVG=MAX(0.0,ZCVG) + cvg=MAX(0.0,cvg) - if(flag_init)then + if(flag_init .and. .not. flag_restart)then sigmab(i)=0.03 else - sigmab(i)=(ZZ*(termA(i)+ZCVG))/(DEN+(1.0-ZZ)) + sigmab(i)=(ZZ*(termA(i)+cvg))/(DEN+(1.0-ZZ)) endif if(sigmab(i)>0.)then sigmab(i)=MIN(sigmab(i),sigmamax(i)) sigmab(i)=MAX(sigmab(i),0.01) endif - + ca_micro(i)=sigmab(i) endif!cnvflg enddo @@ -226,7 +218,20 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & endif enddo enddo + + !Since updraft velocity is much lower in shallow cu region, termC becomes small in shallow cu application, thus the area fraction + !in this regime becomes too large compared with the deep cu region. To address this simply apply a scaling factor for shallow cu + !before computing the massflux to reduce the total strength of the SC MF: + if(flag_shallow)then + do i= 1, im + if(cnvflg(i)) then + sigmab(i)=sigmab(i)/betascu + endif + enddo + endif + + end subroutine progsigma_calc !> @} !! @} diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 7be31a04a..35aea0eb1 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -216,7 +216,7 @@ 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),qlks(im,km), & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im) - + logical flag_shallow c physical parameters ! parameter(grav=grav,asolfac=0.958) ! parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) @@ -1729,7 +1729,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & enddo enddo - if(progsigma)then + if(progsigma)then do k = 2, km1 do i = 1, im if (cnvflg(i)) then @@ -1776,8 +1776,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & c !> - Calculate the mean updraft velocity within the cloud (wc),cast in pressure coordinates. - if(progsigma)then - + if(progsigma)then do i = 1, im omegac(i) = 0. sumx(i) = 0. @@ -1861,17 +1860,19 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & c c store term needed for "termC" in prognostic area fraction closure - do k = 2, km1 - do i = 1, im - dp = 1000. * del(i,k) - if (cnvflg(i)) then - if(k > kbcon(i) .and. k < ktcon(i)) then - zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + - & pwo(i,k)+dellal(i,k)) + if(progsigma)then + do k = 2, km1 + do i = 1, im + dp = 1000. * del(i,k) + if (cnvflg(i)) then + if(k > kbcon(i) .and. k < ktcon(i)) then + zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + + & pwo(i,k)+dellal(i,k)) + endif endif - endif + enddo enddo - enddo + endif ccccc if(lat.==.latd.and.lon.==.lond.and.cnvflg(i)) then ccccc print *, ' aa1(i) before dwndrft =', aa1(i) @@ -2890,10 +2891,10 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & !> - From Bengtsson et al. (2022) Prognostic closure scheme, equation 8, compute updraft area fraction based on a moisture budget if(progsigma)then - call progsigma_calc(im,km,first_time_step,restart, + flag_shallow = .false. + call progsigma_calc(im,km,first_time_step,restart,flag_shallow, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, & qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, - & do_ca, ca_closure, ca_entr, ca_trigger, nthresh, ca_deep, & ca_micro,sigmain,sigmaout,sigmab,errmsg,errflg) endif diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 3eb330551..71f9b87a5 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -70,15 +70,15 @@ type = logical intent = in [tmf] - standard_name = turbulence_moisture_flux - long_name = turbulence_moisture_flux + standard_name = turbulence_moisture_flux_for_coupling_to_convection + long_name = turbulence_moisture_flux_for_coupling_to_convection units = kg kg-1 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in [qmicro] - standard_name = instantanious_moisture_tendency_due_to_microphysics + standard_name = instantaneous_moisture_tendency_due_to_microphysics long_name = moisture tendency due to microphysics units = kg kg-1 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -450,13 +450,13 @@ kind = kind_phys intent = inout [sigmain] - standard_name = updraft_area_fraction + standard_name = prognostic_updraft_area_fraction_in_convection long_name = convective updraft area fraction units = frac dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = inout + intent = in [sigmaout] standard_name = updraft_area_fraction_updated_by_physics long_name = convective updraft area fraction updated by physics diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 24e01b040..6a682e9eb 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -57,11 +57,13 @@ end subroutine samfshalcnv_finalize !! @{ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & eps,epsm1,fv,grav,hvap,rd,rv, & - & t0c,delt,ntk,ntr,delp, & - & prslp,psp,phil,qtr,q1,t1,u1,v1,fscav, & + & t0c,delt,ntk,ntr,delp,first_time_step,restart, & + & tmf,qmicro,progsigma, & + & prslp,psp,phil,qtr,qgrs_dsave,q,q1,t1,u1,v1,fscav, & & rn,kbot,ktop,kcnv,islimsk,garea, & & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, & - & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal,errmsg,errflg) + & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal, + & ca_micro,sigmain,sigmaout,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -74,7 +76,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & eps, epsm1, fv, grav, hvap, rd, rv, t0c real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & - & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:) + & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:), & + & qmicro(:,:),tmf(:,:),qgrs_dsave(:,:),q(:,:),sigmain(:,:) ! real(kind=kind_phys), dimension(:), intent(in) :: fscav integer, intent(inout) :: kcnv(:) @@ -83,12 +86,13 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & q1(:,:), t1(:,:), u1(:,:), v1(:,:) ! integer, intent(out) :: kbot(:), ktop(:) - real(kind=kind_phys), intent(out) :: rn(:), & - & cnvw(:,:), cnvc(:,:), ud_mf(:,:), dt_mf(:,:) + real(kind=kind_phys), intent(out) :: rn(:), ca_micro(:), & + & cnvw(:,:), cnvc(:,:), ud_mf(:,:), dt_mf(:,:), sigmaout(:,:) ! real(kind=kind_phys), intent(in) :: clam, c0s, c1, & & asolfac, evef, pgcon - logical, intent(in) :: hwrf_samfshal + logical, intent(in) :: hwrf_samfshal,first_time_step, & + & restart,progsigma character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! @@ -155,6 +159,13 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & bb1, bb2, wucb cc + +! parameters for prognostic sigma closure + real(kind=kind_phys) omega_u(im,km),zdqca(im,km),qlks(im,km), + & omegac(im),zeta(im,km),dbyo1(im,km), + & sigmab(im) + logical flag_shallow + c physical parameters ! parameter(g=grav,asolfac=0.89) ! parameter(g=grav) @@ -323,6 +334,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! vshear(i) = 0. gdx(i) = sqrt(garea(i)) xmb(i) = 0. + ca_micro(i) = 0. enddo endif !! @@ -498,6 +510,21 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif enddo enddo + + + do i = 1,im + omegac(i)=0. + enddo + + do k = 1, km + do i = 1, im + dbyo1(i,k)=0. + zdqca(i,k)=0. + qlks(i,k)=0. + omega_u(i,k)=0. + zeta(i,k)=1.0 + enddo + enddo ! ! initialize tracer variables ! @@ -1237,6 +1264,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k)= qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp + qlks(i,k)=qlk endif ! ! compute buoyancy and drag for updraft velocity @@ -1304,6 +1332,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(k >= kbcon(i) .and. k < ktcon(i)) then dz1 = zo(i,k+1) - zo(i,k) aa1(i) = aa1(i) + buo(i,k) * dz1 + dbyo1(i,k) = hcko(i,k) - heso(i,k) endif endif enddo @@ -1402,6 +1431,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k) = qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp + qlks(i,k)=qlk endif endif endif @@ -1444,6 +1474,20 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo enddo ! + if(progsigma)then + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + rho = po(i,k)*100. / (rd * to(i,k)) + omega_u(i,k)=-1.0*sqrt(wu2(i,k))*rho*grav + omega_u(i,k)=MAX(omega_u(i,k),-80.) + endif + endif + enddo + enddo + endif + ! compute updraft velocity averaged over the whole cumulus ! !> - Calculate the mean updraft velocity within the cloud (wc). @@ -1475,6 +1519,50 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif enddo c +!> - Calculate the mean updraft velocity in pressure coordinates within the cloud (wc). + if(progsigma)then + do i = 1, im + omegac(i) = 0. + sumx(i) = 0. + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + dp = 1000. * del(i,k) + tem = 0.5 * (omega_u(i,k) + omega_u(i,k-1)) + omegac(i) = omegac(i) + tem * dp + sumx(i) = sumx(i) + dp + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + if(sumx(i) == 0.) then + cnvflg(i)=.false. + else + omegac(i) = omegac(i) / sumx(i) + endif + val = -1.2 + if (omegac(i) > val) cnvflg(i)=.false. + endif + enddo +c +! > - Calculate the mean updraft velocity within the cloud (omega). + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + zeta(i,k)=eta(i,k)*(omegac(i)/omega_u(i,k)) + zeta(i,k)=MAX(0.,zeta(i,k)) + zeta(i,k)=MIN(1.,zeta(i,k)) + endif + endif + enddo + enddo + endif !if progsigma + c exchange ktcon with ktcon1 c do i = 1, im @@ -1505,11 +1593,25 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(dq > 0.) then qlko_ktcon(i) = dq qcko(i,k) = qrch + qlks(i,k) = qlko_ktcon(i) endif endif enddo endif c + + do k = 2, km1 + do i = 1, im + dp = 1000. * del(i,k) + if (cnvflg(i)) then + if(k > kbcon(i) .and. k < ktcon(i)) then + zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + + & pwo(i,k)+dellal(i,k)) + endif + endif + enddo + enddo + c--- compute precipitation efficiency in terms of windshear c !! - Calculate the wind shear and precipitation efficiency according to equation 58 in Fritsch and Chappell (1980) \cite fritsch_and_chappell_1980 : @@ -1824,13 +1926,26 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & c compute cloud base mass flux as a function of the mean c updraft velcoity c +c Prognostic closure + if(progsigma)then + flag_shallow = .true. + call progsigma_calc(im,km,first_time_step,restart,flag_shallow, + & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, + & qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, + & ca_micro,sigmain,sigmaout,sigmab,errmsg,errflg) + 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. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. do i= 1, im if(cnvflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) - xmb(i) = advfac(i)*betaw*rho*wc(i) + if(progsigma)then + xmb(i) = sigmab(i)*((-1.0*omegac(i))/grav) + else + xmb(i) = advfac(i)*betaw*rho*wc(i) + endif endif enddo ! @@ -1850,8 +1965,12 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im if(cnvflg(i)) then if (gdx(i) < dxcrt) then - scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) - scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + if(progsigma)then + scaldfunc(i)=(1.-sigmab(i))*(1.-sigmab(i)) + else + scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) + endif + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) else scaldfunc(i) = 1.0 endif diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index d768d4451..4383b8a67 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = samfshalcnv type = scheme - dependencies = funcphys.f90,machine.F,samfaerosols.F + dependencies = funcphys.f90,machine.F,samfaerosols.F,progsigma_calc.f90 ######################################################################## [ccpp-arg-table] @@ -55,6 +55,36 @@ dimensions = () type = integer intent = in +[first_time_step] + standard_name = flag_for_first_timestep + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[tmf] + standard_name = turbulence_moisture_flux_for_coupling_to_convection + long_name = turbulence_moisture_flux_for_coupling_to_convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qmicro] + standard_name = instantaneous_moisture_tendency_due_to_microphysics + long_name = moisture tendency due to microphysics + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [itc] standard_name = index_of_first_chemical_tracer_for_convection long_name = index of first chemical tracer transported/scavenged by convection @@ -219,6 +249,22 @@ type = real kind = kind_phys intent = inout +[qgrs_dsave] + standard_name = tracer_concentration_dsave + long_name = model layer mean tracer concentration dsave + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[q] + standard_name = specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [q1] standard_name = specific_humidity_of_new_state long_name = updated vapor specific humidity @@ -413,6 +459,37 @@ dimensions = () type = logical intent = in +[progsigma] + standard_name = flag_for_prognostic_sigma + long_name = flag for prognostic sigma + units = flag + dimensions = () + type = logical + intent = in +[ca_micro] + standard_name = output_prognostic_sigma_two + long_name = output of prognostic area fraction two + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[sigmain] + standard_name = prognostic_updraft_area_fraction_in_convection + long_name = convective updraft area fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sigmaout] + standard_name = updraft_area_fraction_updated_by_physics + long_name = convective updraft area fraction updated by physics + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index b0367b4d4..0fce7dd9a 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -121,9 +121,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & real(kind=kind_phys), intent(out) :: & & dusfc(:), dvsfc(:), & & dtsfc(:), dqsfc(:), & - & hpbl(:), tmf(:,:) + & hpbl(:) real(kind=kind_phys), intent(out) :: & - & dkt(:,:), dku(:,:) + & dkt(:,:), dku(:,:), tmf(:,:) ! logical, intent(in) :: dspheat character(len=*), intent(out) :: errmsg @@ -299,6 +299,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & xmfd(i,k) = 0. buou(i,k) = 0. buod(i,k) = 0. + tmf(i,k) = 0. ckz(i,k) = ck1 chz(i,k) = ch1 rlmnz(i,k) = rlmn0 diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 211bbaec6..9b803e4a5 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -202,10 +202,10 @@ kind = kind_phys intent = inout [tmf] - standard_name = turbulence_moisture_flux - long_name = turbulence_moisture_flux + standard_name = turbulence_moisture_flux_for_coupling_to_convection + long_name = turbulence_moisture_flux_for_coupling_to_convection units = kg kg-1 s-1 - dimensions = (horizontal_dimension,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = out From b530db11801ca67a10e2757aef04ed9492a06e7e Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Wed, 20 Apr 2022 01:29:13 +0000 Subject: [PATCH 171/217] cleaning some diagnostics --- physics/progsigma_calc.f90 | 5 +---- physics/samfdeepcnv.f | 8 +++----- physics/samfdeepcnv.meta | 8 -------- physics/samfshalcnv.f | 7 +++---- physics/samfshalcnv.meta | 8 -------- 5 files changed, 7 insertions(+), 29 deletions(-) diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index ca05f6778..7673602b6 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -16,7 +16,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & flag_shallow,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & delt,qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, & - ca_micro,sigmain,sigmaout,sigmab,errmsg,errflg) + sigmain,sigmaout,sigmab,errmsg,errflg) ! ! use machine, only : kind_phys @@ -31,7 +31,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & omega_u(im,km),zeta(im,km),gdx(im) logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow - real(kind=kind_phys), intent(out):: ca_micro(im) real(kind=kind_phys), intent(in) :: sigmain(im,km) ! intent out @@ -79,7 +78,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & termD(i)=0. fdqa(i)=0. mcons(i)=0. - ca_micro(i)=0. enddo !Initial computations, place maximum sigmain in sigmab @@ -207,7 +205,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & sigmab(i)=MIN(sigmab(i),sigmamax(i)) sigmab(i)=MAX(sigmab(i),0.01) endif - ca_micro(i)=sigmab(i) endif!cnvflg enddo diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 35aea0eb1..45cbf70e1 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -86,7 +86,7 @@ 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, ca_micro, & + & rainevap, sigmain, sigmaout, & & errmsg,errflg) ! use machine , only : kind_phys @@ -108,7 +108,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & & tmf(:,:),q(:,:), qgrs_dsave(:,:) - real(kind=kind_phys), intent(out) :: rainevap(:),ca_micro(:) + 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 @@ -919,8 +919,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & enddo if(totflg) return !! -! -!Lisa: at this point only trigger criteria is set ! turbulent entrainment rate assumed to be proportional ! to subcloud mean TKE @@ -2895,7 +2893,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & call progsigma_calc(im,km,first_time_step,restart,flag_shallow, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, & qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, - & ca_micro,sigmain,sigmaout,sigmab,errmsg,errflg) + & sigmain,sigmaout,sigmab,errmsg,errflg) 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/samfdeepcnv.meta index 71f9b87a5..71c78036d 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -326,14 +326,6 @@ dimensions = () type = logical intent = in -[ca_micro] - standard_name = output_prognostic_sigma_two - long_name = output of prognostic area fraction two - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out [cldwrk] standard_name = cloud_work_function long_name = cloud work function diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 6a682e9eb..343691279 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -63,7 +63,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, - & ca_micro,sigmain,sigmaout,errmsg,errflg) + & sigmain,sigmaout,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -86,7 +86,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & q1(:,:), t1(:,:), u1(:,:), v1(:,:) ! integer, intent(out) :: kbot(:), ktop(:) - real(kind=kind_phys), intent(out) :: rn(:), ca_micro(:), & + real(kind=kind_phys), intent(out) :: rn(:), & & cnvw(:,:), cnvc(:,:), ud_mf(:,:), dt_mf(:,:), sigmaout(:,:) ! real(kind=kind_phys), intent(in) :: clam, c0s, c1, & @@ -334,7 +334,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! vshear(i) = 0. gdx(i) = sqrt(garea(i)) xmb(i) = 0. - ca_micro(i) = 0. enddo endif !! @@ -1932,7 +1931,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & call progsigma_calc(im,km,first_time_step,restart,flag_shallow, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, & qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, - & ca_micro,sigmain,sigmaout,sigmab,errmsg,errflg) + & sigmain,sigmaout,sigmab,errmsg,errflg) 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/samfshalcnv.meta index 4383b8a67..895460ffd 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -466,14 +466,6 @@ dimensions = () type = logical intent = in -[ca_micro] - standard_name = output_prognostic_sigma_two - long_name = output of prognostic area fraction two - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out [sigmain] standard_name = prognostic_updraft_area_fraction_in_convection long_name = convective updraft area fraction From 121be9905a7267e22c7bb967e4102ec3b0d42caf Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 20 Apr 2022 12:37:02 -0500 Subject: [PATCH 172/217] Use restart flag for setting local itimestep --- physics/mp_nssl.F90 | 11 +++++++++-- physics/mp_nssl.meta | 7 +++++++ 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 7101d50b0..1b1ea874f 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -132,7 +132,13 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & ihvol=ihailv,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) + ! For restart runs, the init is done here + if (restart) then + is_initialized = .true. + return + end if +! Other initialization operation here.... is_initialized = .true. @@ -155,7 +161,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ccw, crw, cci, csw, chw, chl, vh, vhl, & tgrs, prslk, prsl, phii, omega, dtp, & prcp, rain, graupel, ice, snow, sr, & - refl_10cm, do_radar_ref, first_time_step, & + refl_10cm, do_radar_ref, first_time_step, restart, & re_cloud, re_ice, re_snow, re_rain, & nleffr, nieffr, nseffr, nreffr, & imp_physics, convert_dry_rho, & @@ -206,6 +212,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ! Radar reflectivity real(kind_phys), intent(inout) :: refl_10cm(:,:) !(1:ncol,1:nlev) logical, intent(in ) :: do_radar_ref, first_time_step + logical, intent(in) :: restart ! Cloud effective radii real(kind_phys), intent(inout) :: re_cloud(:,:) ! (1:ncol,1:nlev) real(kind_phys), intent(inout) :: re_ice(:,:) ! (1:ncol,1:nlev) @@ -492,7 +499,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ntmul = 1 ENDIF - IF ( first_time_step ) THEN + IF ( first_time_step .and. .not. restart ) 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.meta index 43350fd10..82b5ff739 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -481,6 +481,13 @@ dimensions = () type = logical intent = in +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in [re_cloud] standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle long_name = eff. radius of cloud liquid water particle in micrometer From 1b8c8173ceaa311f93bb19131afe4dd007a0a6b5 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 20 Apr 2022 13:21:30 -0400 Subject: [PATCH 173/217] address review comments by changing Doxygen inline comments --- physics/GFS_GWD_generic_post.F90 | 7 ++++--- physics/dcyc2t3.f | 2 +- physics/fv_sat_adj.F90 | 2 +- physics/get_phi_fv3.F90 | 3 +++ physics/get_prs_fv3.F90 | 4 ++++ physics/hedmf.f | 2 +- physics/lsm_noah.f | 2 +- physics/lsm_ruc.F90 | 2 +- physics/myjpbl_wrapper.F90 | 2 +- physics/myjsfc_wrapper.F90 | 2 +- physics/mynnpbl_wrapper.F90 | 2 +- physics/mynnsfc_wrapper.F90 | 2 +- physics/noahmpdrv.F90 | 2 +- physics/shoc.F90 | 2 +- physics/zhaocarr_gscond.f | 2 +- physics/zhaocarr_precpd.f | 2 +- 16 files changed, 24 insertions(+), 16 deletions(-) diff --git a/physics/GFS_GWD_generic_post.F90 b/physics/GFS_GWD_generic_post.F90 index b3538c2b0..58f18567d 100644 --- a/physics/GFS_GWD_generic_post.F90 +++ b/physics/GFS_GWD_generic_post.F90 @@ -1,15 +1,16 @@ -!> This module contains the CCPP-compliant orographic gravity wave drag post +!> \file GFS_gwd_generic_post.F90 +!! This file contains the CCPP-compliant orographic gravity wave drag post !! interstitial codes. module GFS_GWD_generic_post contains -!! \section arg_table_GFS_GWD_generic_post_run Argument Table +!> \section arg_table_GFS_GWD_generic_post_run Argument Table !! \htmlinclude GFS_GWD_generic_post_run.html !! !! \section general General Algorithm !! \section detailed Detailed Algorithm -!! @{ +!> @{ subroutine GFS_GWD_generic_post_run(lssav, ldiag3d, dtf, dusfcg, dvsfcg, dudt, dvdt, dtdt, & & dugwd, dvgwd, flag_for_gwd_generic_tend, dtend, dtidx, index_of_temperature, index_of_x_wind, & & index_of_y_wind, index_of_process_orographic_gwd, errmsg, errflg) diff --git a/physics/dcyc2t3.f b/physics/dcyc2t3.f index 780d72efb..21ab5da2a 100644 --- a/physics/dcyc2t3.f +++ b/physics/dcyc2t3.f @@ -1,4 +1,4 @@ -!>\file dcyc2.f +!>\file dcyc2t3.f !! This file contains the CCPP-compliant dcyc2t3 codes that fits !! radiative fluxes and heating rates from a coarse radiation !! calculation time interval into model's more frequent time steps. diff --git a/physics/fv_sat_adj.F90 b/physics/fv_sat_adj.F90 index 816488f7a..53543485b 100644 --- a/physics/fv_sat_adj.F90 +++ b/physics/fv_sat_adj.F90 @@ -1,4 +1,4 @@ -!>\file gfdl_fv_sat_adj.F90 +!>\file fv_sat_adj.F90 !! This file contains the GFDL in-core fast saturation adjustment. !! and it is an "intermediate physics" implemented in the remapping Lagrangian to !! Eulerian loop of FV3 solver. diff --git a/physics/get_phi_fv3.F90 b/physics/get_phi_fv3.F90 index 157a29f56..d111d3ae0 100644 --- a/physics/get_phi_fv3.F90 +++ b/physics/get_phi_fv3.F90 @@ -1,3 +1,6 @@ +!>\file get_phi_fv3.F90 +!! This file contains a subroutine to calculate geopotential from within physics. + module get_phi_fv3 use machine, only: kind_phys diff --git a/physics/get_prs_fv3.F90 b/physics/get_prs_fv3.F90 index bff48a97d..0234f26c9 100644 --- a/physics/get_prs_fv3.F90 +++ b/physics/get_prs_fv3.F90 @@ -1,3 +1,7 @@ +!>\file get_prs_fv3.F90 +!! This file contains a subroutine to "adjust the geopotential height hydrostatically in a way consistent with FV3 discretization," +!! according to SJ Lin. + module get_prs_fv3 use machine, only: kind_phys diff --git a/physics/hedmf.f b/physics/hedmf.f index 19e055da4..83d0fe1b0 100644 --- a/physics/hedmf.f +++ b/physics/hedmf.f @@ -1,4 +1,4 @@ -!> \file moninedmf.f +!> \file hedmf.f !! Contains most of the hybrid eddy-diffusivity mass-flux scheme except for the !! subroutine that calculates the mass flux and updraft properties. diff --git a/physics/lsm_noah.f b/physics/lsm_noah.f index e61d3be5e..d519dcda5 100644 --- a/physics/lsm_noah.f +++ b/physics/lsm_noah.f @@ -1,4 +1,4 @@ -!> \file sfc_drv.f +!> \file lsm_noah.f !! This file contains the Noah land surface scheme driver. !> This module contains the CCPP-compliant Noah land surface scheme driver. diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 17b38268d..3ca78ad04 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -1,4 +1,4 @@ -!>\file sfc_drv_ruc.F90 +!>\file lsm_ruc.F90 !! This file contains the RUC land surface scheme driver. module lsm_ruc diff --git a/physics/myjpbl_wrapper.F90 b/physics/myjpbl_wrapper.F90 index 9010b4cdb..5c47d7168 100644 --- a/physics/myjpbl_wrapper.F90 +++ b/physics/myjpbl_wrapper.F90 @@ -1,4 +1,4 @@ -!> \file module_myjpbl_wrapper.F90 +!> \file myjpbl_wrapper.F90 !! Contains all of the code related to running the MYJ PBL scheme MODULE myjpbl_wrapper diff --git a/physics/myjsfc_wrapper.F90 b/physics/myjsfc_wrapper.F90 index 3d2b2e017..d7737e911 100644 --- a/physics/myjsfc_wrapper.F90 +++ b/physics/myjsfc_wrapper.F90 @@ -1,4 +1,4 @@ -!> \file module_myjsfc_wrapper.F90 +!> \file myjsfc_wrapper.F90 !! Contains all of the code related to running the MYJ surface layer scheme MODULE myjsfc_wrapper diff --git a/physics/mynnpbl_wrapper.F90 b/physics/mynnpbl_wrapper.F90 index 64892e542..13bb1f076 100644 --- a/physics/mynnpbl_wrapper.F90 +++ b/physics/mynnpbl_wrapper.F90 @@ -1,4 +1,4 @@ -!> \file module_MYNNPBL_wrapper.F90 +!> \file MYNNPBL_wrapper.F90 !! This file contains all of the code related to running the MYNN !! eddy-diffusivity mass-flux scheme. diff --git a/physics/mynnsfc_wrapper.F90 b/physics/mynnsfc_wrapper.F90 index 150a66472..efcdc888a 100644 --- a/physics/mynnsfc_wrapper.F90 +++ b/physics/mynnsfc_wrapper.F90 @@ -1,4 +1,4 @@ -!> \file module_mynnsfc_wrapper.F90 +!> \file mynnsfc_wrapper.F90 !! Contains all of the code related to running the MYNN surface layer scheme MODULE mynnsfc_wrapper diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index 0ebcbd615..14f26b28f 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -1,5 +1,5 @@ #define CCPP -!> \file sfc_noahmp_drv.F90 +!> \file noahmpdrv.F90 !! This file contains the NoahMP land surface scheme driver. !>\defgroup NoahMP_LSM NoahMP LSM Model diff --git a/physics/shoc.F90 b/physics/shoc.F90 index 4852310fc..4e49fad40 100644 --- a/physics/shoc.F90 +++ b/physics/shoc.F90 @@ -1,4 +1,4 @@ -!> \file gcm_shoc.F90 +!> \file shoc.F90 !! Contains the Simplified Higher-Order Closure (SHOC) scheme. !> This module contains the CCPP-compliant SHOC scheme. diff --git a/physics/zhaocarr_gscond.f b/physics/zhaocarr_gscond.f index 8756bc320..d35e08342 100644 --- a/physics/zhaocarr_gscond.f +++ b/physics/zhaocarr_gscond.f @@ -1,4 +1,4 @@ -!> \file gscond.f +!> \file zhaocarr_gscond.f !! This file contains the subroutine that calculates grid-scale !! condensation and evaporation for use in Zhao and Carr (1997) !! \cite zhao_and_carr_1997 scheme. diff --git a/physics/zhaocarr_precpd.f b/physics/zhaocarr_precpd.f index 929d78f9c..16f0ba4f1 100644 --- a/physics/zhaocarr_precpd.f +++ b/physics/zhaocarr_precpd.f @@ -1,4 +1,4 @@ -!> \file precpd.f +!> \file zhaocarr_precpd.f !! This file contains the subroutine that calculates precipitation !! processes from suspended cloud water/ice. From ceba3dd64574666fade9a74648268a1ae9a32a64 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 20 Apr 2022 21:16:19 -0500 Subject: [PATCH 174/217] Fixed an inconsistency in how 'cn' is written back for output --- physics/module_mp_nssl_2mom.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index e6f2ae162..b34fa755e 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -2884,7 +2884,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN ! not used here ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN - IF ( lccna > 1 .and. .not. present( cna ) ) THEN + IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) ELSE cn(ix,kz,jy) = an(ix,1,kz,lccn) From 888390cf03128337465790f2fab998c68d5ee815 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 20 Apr 2022 23:05:35 -0500 Subject: [PATCH 175/217] Test treating cccn as cna when invertccn=true --- physics/mp_nssl.F90 | 35 ++++++++++++++++++++++------------- 1 file changed, 22 insertions(+), 13 deletions(-) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 1b1ea874f..5a49c2acf 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -546,12 +546,18 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN ! cn_mp = Max(0.0, nssl_qccn - Max(0.0,cccn)) - DO k = 1,nlev - DO i = 1,ncol - cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn_mp(i,k)) ) -! cn_mp(i,k) = Min(nssl_qccn, nssl_qccn - cccn(i,k) ) - ENDDO - ENDDO + +! 4/20/2022 test turning this off and just use cccn as cccna +! DO k = 1,nlev +! DO i = 1,ncol +! cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn_mp(i,k)) ) +! ! cn_mp(i,k) = Min(nssl_qccn, nssl_qccn - cccn(i,k) ) +! ENDDO +! ENDDO + + cna_mp = cccn_mp + cn_mp = nssl_qccn + ! DO k = 1,nlev ! DO i = 1,ncol ! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) @@ -599,7 +605,8 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & VHL=vhl_mp, & cn=cn_mp, & ! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use - cna=cna_mp, f_cna=.false. , & +! cna=cna_mp, f_cna=.false. , & + cna=cna_mp, f_cna=invertccn , & PII=prslk, & P=prsl, & W=w, & @@ -696,12 +703,14 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN !cccn = Max(0.0, nssl_qccn - cn_mp ) - DO k = 1,nlev - DO i = 1,ncol -! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) - cccn_mp(i,k) = nssl_qccn - cn_mp(i,k) - ENDDO - ENDDO + + cccn_mp = cna_mp +! DO k = 1,nlev +! DO i = 1,ncol +! ! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) +! cccn_mp(i,k) = nssl_qccn - cn_mp(i,k) +! ENDDO +! ENDDO ELSE cccn_mp = cn_mp ENDIF From e65360a7cca318794262f15d4299d71005e4e8fd Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 21 Apr 2022 00:00:00 -0500 Subject: [PATCH 176/217] Turn on lccna in nssl_params --- physics/mp_nssl.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 5a49c2acf..122833b04 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -115,7 +115,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & nssl_params(10) = 100. ! nssl_rho_qs nssl_params(11) = 0 ! nssl_ipelec_tmp nssl_params(12) = 11 ! nssl_isaund - nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off + nssl_params(13) = 1 ! 0 ! 1= turn on cccna; 0 = turn off nssl_qccn = nssl_cccn/1.225 ! if (mpirank==mpiroot) then From 1ff1f161edb15c865a2bbd20e517aaad04a16b8a Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 21 Apr 2022 08:35:26 -0500 Subject: [PATCH 177/217] Try implicit loop for invertccn --- physics/mp_nssl.F90 | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 122833b04..3f0d136de 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -115,7 +115,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & nssl_params(10) = 100. ! nssl_rho_qs nssl_params(11) = 0 ! nssl_ipelec_tmp nssl_params(12) = 11 ! nssl_isaund - nssl_params(13) = 1 ! 0 ! 1= turn on cccna; 0 = turn off + nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off nssl_qccn = nssl_cccn/1.225 ! if (mpirank==mpiroot) then @@ -547,17 +547,13 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & IF ( invertccn ) THEN ! cn_mp = Max(0.0, nssl_qccn - Max(0.0,cccn)) -! 4/20/2022 test turning this off and just use cccn as cccna -! DO k = 1,nlev -! DO i = 1,ncol -! cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn_mp(i,k)) ) -! ! cn_mp(i,k) = Min(nssl_qccn, nssl_qccn - cccn(i,k) ) -! ENDDO +! DO k = 1,nlev +! DO i = 1,ncol + cn_mp = Max(0.0, nssl_qccn - Max(0.0, cccn_mp) ) +! cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn_mp(i,k)) ) +! cn_mp(i,k) = Min(nssl_qccn, nssl_qccn - cccn(i,k) ) ! ENDDO - - cna_mp = cccn_mp - cn_mp = nssl_qccn - +! ENDDO ! DO k = 1,nlev ! DO i = 1,ncol ! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) @@ -605,8 +601,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & VHL=vhl_mp, & cn=cn_mp, & ! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use -! cna=cna_mp, f_cna=.false. , & - cna=cna_mp, f_cna=invertccn , & + cna=cna_mp, f_cna=.false. , & PII=prslk, & P=prsl, & W=w, & @@ -703,8 +698,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN !cccn = Max(0.0, nssl_qccn - cn_mp ) - - cccn_mp = cna_mp + cccn_mp = nssl_qccn - cn_mp ! DO k = 1,nlev ! DO i = 1,ncol ! ! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) From fc7e7a0e226663e0fec80729097a7dc69ed5551d Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Fri, 22 Apr 2022 04:00:31 +0000 Subject: [PATCH 178/217] addressing some review comments --- physics/GFS_MP_generic.F90 | 16 +++--- physics/GFS_MP_generic.meta | 12 ++--- physics/progsigma_calc.f90 | 103 ++++++++++++++++++------------------ physics/samfdeepcnv.f | 10 ++-- physics/samfdeepcnv.meta | 14 ++--- physics/samfshalcnv.f | 12 +++-- physics/samfshalcnv.meta | 14 ++--- physics/satmedmfvdifq.meta | 4 +- 8 files changed, 95 insertions(+), 90 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index dbf2d15fa..f8dd8ab6c 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -95,7 +95,7 @@ subroutine GFS_MP_generic_post_run( drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & - fh_dfi_radar,index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, qgrs_dsave, & + fh_dfi_radar,index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, prevsq, & errmsg, errflg) ! use machine, only: kind_phys @@ -150,7 +150,7 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), dimension(:), intent(inout) :: dsnowprv real(kind=kind_phys), dimension(:), intent(inout) :: dgraupelprv real(kind=kind_phys), dimension(:,:), intent(out) :: dqdt_qmicro - real(kind=kind_phys), dimension(:,:), intent(out) :: qgrs_dsave + real(kind=kind_phys), dimension(:,:), intent(out) :: prevsq real(kind=kind_phys), intent(in) :: dtp ! CCPP error handling @@ -466,11 +466,13 @@ subroutine GFS_MP_generic_post_run( pwat(i) = pwat(i) * onebg enddo - do k = 1, levs - do i=1, im - qgrs_dsave(i,k) = gq0(i,k,1) - enddo - enddo + if(progsigma)then + do k = 1, levs + do i=1, im + prevsq(i,k) = gq0(i,k,1) + enddo + enddo + endif end subroutine GFS_MP_generic_post_run !> @} diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index 763cad85a..eb0f17fa8 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -249,8 +249,8 @@ type = logical intent = in [progsigma] - standard_name = flag_for_prognostic_sigma - long_name = flag for prognostic sigma + standard_name = do_prognostic_updraft_area_fraction + long_name = flag for prognostic sigma in cumulus scheme units = flag dimensions = () type = logical @@ -852,16 +852,16 @@ type = logical intent = in [dqdt_qmicro] - standard_name = instantaneous_moisture_tendency_due_to_microphysics + standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics long_name = moisture tendency due to microphysics units = kg kg-1 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = out -[qgrs_dsave] - standard_name = tracer_concentration_dsave - long_name = model layer mean tracer concentration dsave +[prevsq] + standard_name = specific_humidity_on_previous_timestep + long_name = specific_humidity_on_previous_timestep units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index 7673602b6..58a6fc0ef 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -1,4 +1,4 @@ -!>\file progsigma +!>\file progsigma_calc.f90 !! This file contains the subroutine that calculates the prognostic !! updraft area fraction that is used for closure computations in !! saSAS deep and shallow convection, based on a moisture budget @@ -15,7 +15,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & flag_shallow,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & - delt,qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, & + delt,prevsq,q,kbcon1,ktcon,cnvflg,gdx, & sigmain,sigmaout,sigmab,errmsg,errflg) ! ! @@ -27,7 +27,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! intent in integer, intent(in) :: im,km,kbcon1(im),ktcon(im) real, intent(in) :: hvap,delt - real, intent(in) :: qgrs_dsave(im,km), q(im,km),del(im,km), & + real, intent(in) :: prevsq(im,km), q(im,km),del(im,km), & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & omega_u(im,km),zeta(im,km),gdx(im) logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow @@ -43,33 +43,32 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & integer :: i,k,km1 real(kind=kind_phys) :: termA(im),termB(im),termC(im),termD(im), & mcons(im),fdqa(im),form(im,km), & - qadv(im,km),sigmamax(im) + qadv(im,km),sigmamax(im),dp(im),inbu(im,km) real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, & - fdqb,dtdyn,dxlim,rmulacvg,dp,tem, & - alpha,DEN,betascu - integer :: inbu(im,km) + fdqb,dtdyn,dxlim,rmulacvg,tem, & + alpha,DEN,betascu,dp1 !Parameters - gcvalmx = 0.1 - rmulacvg=10. - epsilon=1.E-11 - km1=km-1 - alpha=7000. - betascu = 3.0 + gcvalmx = 0.1 + rmulacvg=10. + epsilon=1.E-11 + km1=km-1 + alpha=7000. + betascu = 3.0 !Initialization 2D - do k = 1,km - do i = 1,im - sigmaout(i,k)=0. - inbu(i,k)=0 - form(i,k)=0. - enddo - enddo + do k = 1,km + do i = 1,im + sigmaout(i,k)=0. + inbu(i,k)=0. + form(i,k)=0. + enddo + enddo !Initialization 1D - do i=1,im + do i=1,im sigmab(i)=0. sigmamax(i)=0.95 termA(i)=0. @@ -80,23 +79,32 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & mcons(i)=0. enddo - !Initial computations, place maximum sigmain in sigmab + do k = 2,km1 + do i = 1,im + if(cnvflg(i))then + dp(i) = 1000. * del(i,k) + endif + enddo + enddo - do k=2,km - do i=1,im - if(flag_init .and. .not. flag_restart)then + !Initial computations, place maximum sigmain in sigmab + if(flag_init .and. .not. flag_restart)then + do i=1,im if(cnvflg(i))then sigmab(i)=0.03 endif - else + enddo + else + do i=1,im if(cnvflg(i))then - if(sigmain(i,k)>sigmab(i))then - sigmab(i)=sigmain(i,k) - endif + do k=2,km + if(sigmain(i,k)>sigmab(i))then + sigmab(i)=sigmain(i,k) + endif + enddo endif - endif - enddo - enddo + enddo + endif do i=1,im if(sigmab(i) < 1.E-5)then !after advection @@ -116,7 +124,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & if(flag_init .and. .not.flag_restart)then qadv(i,k)=0. else - qadv(i,k)=(q(i,k) - qgrs_dsave(i,k))/delt + qadv(i,k)=(q(i,k) - prevsq(i,k))/delt endif enddo enddo @@ -125,22 +133,21 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & !buoyant layers with positive moisture convergence (accumulated from the surface). !Lowest level: do i = 1,im - dp = 1000. * del(i,1) - mcons(i)=(hvap*(qadv(i,1)+tmf(i,1)+qmicro(i,1))*dp) + dp1 = 1000. * del(i,1) + mcons(i)=(hvap*(qadv(i,1)+tmf(i,1)+qmicro(i,1))*dp1) enddo !Levels above: do k = 2,km1 do i = 1,im - dp = 1000. * del(i,k) if(cnvflg(i))then - mcon = (hvap*(qadv(i,k)+tmf(i,k)+qmicro(i,k))*dp) + mcon = (hvap*(qadv(i,k)+tmf(i,k)+qmicro(i,k))*dp(i)) buy2 = termD(i)+mcon+mcons(i) ! Do the integral over buoyant layers with positive mcon acc from surface if(k > kbcon1(i) .and. k < ktcon(i) .and. buy2 > 0.)then - inbu(i,k)=1 + inbu(i,k)=1. endif inbu(i,k-1)=MAX(inbu(i,k-1),inbu(i,k)) - termD(i) = termD(i) + float(inbu(i,k-1))*mcons(i) + termD(i) = termD(i) + inbu(i,k-1)*mcons(i) mcons(i)=mcon endif enddo @@ -149,9 +156,8 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & !termA do k = 2,km1 do i = 1,im - dp = 1000. * del(i,k) if(cnvflg(i))then - tem=(sigmab(i)*zeta(i,k)*float(inbu(i,k))*dbyo1(i,k))*dp + tem=(sigmab(i)*zeta(i,k)*inbu(i,k)*dbyo1(i,k))*dp(i) termA(i)=termA(i)+tem endif enddo @@ -160,9 +166,8 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & !termB do k = 2,km1 do i = 1,im - dp = 1000. * del(i,k) if(cnvflg(i))then - tem=(dbyo1(i,k)*float(inbu(i,k)))*dp + tem=(dbyo1(i,k)*inbu(i,k))*dp(i) termB(i)=termB(i)+tem endif enddo @@ -172,10 +177,9 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do k = 2,km1 do i = 1,im if(cnvflg(i))then - dp = 1000. * del(i,k) - form(i,k)=-1.0*float(inbu(i,k))*(omega_u(i,k)*delt) + form(i,k)=-1.0*inbu(i,k)*(omega_u(i,k)*delt) fdqb=0.5*((form(i,k)*zdqca(i,k))) - termC(i)=termC(i)+(float(inbu(i,k))* & + termC(i)=termC(i)+inbu(i,k)* & (fdqb+fdqa(i))*hvap*zeta(i,k)) fdqa(i)=fdqb endif @@ -185,22 +189,17 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & !sigmab do i = 1,im if(cnvflg(i))then - DEN=MIN(termC(i)+termB(i),1.E8) cvg=termD(i)*delt ZZ=MAX(0.0,SIGN(1.0,termA(i))) & *MAX(0.0,SIGN(1.0,termB(i))) & - *MAX(0.0,SIGN(1.0,termC(i)-epsilon)) - - + *MAX(0.0,SIGN(1.0,termC(i)-epsilon)) cvg=MAX(0.0,cvg) - if(flag_init .and. .not. flag_restart)then sigmab(i)=0.03 else sigmab(i)=(ZZ*(termA(i)+cvg))/(DEN+(1.0-ZZ)) endif - if(sigmab(i)>0.)then sigmab(i)=MIN(sigmab(i),sigmamax(i)) sigmab(i)=MAX(sigmab(i),0.01) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 45cbf70e1..02b2dcb83 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -79,7 +79,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & tmf,qmicro,itc,ntc,cliq,cp,cvap, & & eps,epsm1,fv,grav,hvap,rd,rv, & & t0c,delt,ntk,ntr,delp, & - & prslp,psp,phil,qtr,qgrs_dsave,q,q1,t1,u1,v1,fscav, & + & prslp,psp,phil,qtr,prevsq,q,q1,t1,u1,v1,fscav, & & hwrf_samfdeep,progsigma,wclosureflg,cldwrk,rn,kbot,ktop,kcnv, & & islimsk,garea,dot,ncloud,hpbl,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & & QLCN, QICN, w_upi, cf_upi, CNV_MFD, & @@ -107,7 +107,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & real(kind=kind_phys), intent(in) :: nthresh real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & - & tmf(:,:),q(:,:), qgrs_dsave(:,:) + & tmf(:,:),q(:,:), prevsq(:,:) real(kind=kind_phys), intent(out) :: rainevap(:) real(kind=kind_phys), intent(out) :: sigmaout(:,:) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger @@ -217,6 +217,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & real(kind=kind_phys) omega_u(im,km),zdqca(im,km),qlks(im,km), & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im) logical flag_shallow + real(kind=kind_phys) gravinv c physical parameters ! parameter(grav=grav,asolfac=0.958) ! parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) @@ -309,6 +310,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & errmsg = '' errflg = 0 + gravinv = 1./grav elocp = hvap/cp el2orc = hvap*hvap/(rv*cp) @@ -2892,7 +2894,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & flag_shallow = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, + & prevsq,q,kbcon1,ktcon,cnvflg,gdx, & sigmain,sigmaout,sigmab,errmsg,errflg) endif @@ -2903,7 +2905,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) if(progsigma)then - xmb(i) = sigmab(i)*((-1.0*omegac(i))/grav) + xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) else xmb(i) = advfac(i)*betaw*rho*wc(i) endif diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 71c78036d..e956d24ed 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -70,8 +70,8 @@ type = logical intent = in [tmf] - standard_name = turbulence_moisture_flux_for_coupling_to_convection - long_name = turbulence_moisture_flux_for_coupling_to_convection + standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL units = kg kg-1 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real @@ -249,9 +249,9 @@ type = real kind = kind_phys intent = inout -[qgrs_dsave] - standard_name = tracer_concentration_dsave - long_name = model layer mean tracer concentration dsave +[prevsq] + standard_name = specific_humidity_on_previous_timestep + long_name = specific_humidity_on_previous_timestep units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real @@ -320,8 +320,8 @@ type = logical intent = in [progsigma] - standard_name = flag_for_prognostic_sigma - long_name = flag for prognostic sigma + standard_name = do_prognostic_updraft_area_fraction + long_name = flag for prognostic sigma in cumuls scheme units = flag dimensions = () type = logical diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 343691279..c3bb842b3 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -59,7 +59,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & eps,epsm1,fv,grav,hvap,rd,rv, & & t0c,delt,ntk,ntr,delp,first_time_step,restart, & & tmf,qmicro,progsigma, & - & prslp,psp,phil,qtr,qgrs_dsave,q,q1,t1,u1,v1,fscav, & + & prslp,psp,phil,qtr,prevsq,q,q1,t1,u1,v1,fscav, & & rn,kbot,ktop,kcnv,islimsk,garea, & & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, & & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal, @@ -77,7 +77,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:), & - & qmicro(:,:),tmf(:,:),qgrs_dsave(:,:),q(:,:),sigmain(:,:) + & qmicro(:,:),tmf(:,:),prevsq(:,:),q(:,:),sigmain(:,:) ! real(kind=kind_phys), dimension(:), intent(in) :: fscav integer, intent(inout) :: kcnv(:) @@ -165,6 +165,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & omegac(im),zeta(im,km),dbyo1(im,km), & sigmab(im) logical flag_shallow + real(kind=kind_phys) gravinv c physical parameters ! parameter(g=grav,asolfac=0.89) @@ -249,6 +250,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & errmsg = '' errflg = 0 + gravinv = 1./grav + elocp = hvap/cp el2orc = hvap*hvap/(rv*cp) @@ -1601,7 +1604,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & do k = 2, km1 do i = 1, im - dp = 1000. * del(i,k) if (cnvflg(i)) then if(k > kbcon(i) .and. k < ktcon(i)) then zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + @@ -1930,7 +1932,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & flag_shallow = .true. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & qgrs_dsave,q,kbcon1,ktcon,cnvflg,gdx, + & prevsq,q,kbcon1,ktcon,cnvflg,gdx, & sigmain,sigmaout,sigmab,errmsg,errflg) endif @@ -1941,7 +1943,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) if(progsigma)then - xmb(i) = sigmab(i)*((-1.0*omegac(i))/grav) + xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) else xmb(i) = advfac(i)*betaw*rho*wc(i) endif diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index 895460ffd..a4cca64b8 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -70,8 +70,8 @@ type = logical intent = in [tmf] - standard_name = turbulence_moisture_flux_for_coupling_to_convection - long_name = turbulence_moisture_flux_for_coupling_to_convection + standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL units = kg kg-1 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real @@ -249,9 +249,9 @@ type = real kind = kind_phys intent = inout -[qgrs_dsave] - standard_name = tracer_concentration_dsave - long_name = model layer mean tracer concentration dsave +[prevsq] + standard_name = specific_humidity_on_previous_timestep + long_name = specific_humidity_on_previous_timestep units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real @@ -460,8 +460,8 @@ type = logical intent = in [progsigma] - standard_name = flag_for_prognostic_sigma - long_name = flag for prognostic sigma + standard_name = do_prognostic_updraft_area_fraction + long_name = flag for prognostic sigma in cumulus scheme units = flag dimensions = () type = logical diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 9b803e4a5..fa30cd9f7 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -202,8 +202,8 @@ kind = kind_phys intent = inout [tmf] - standard_name = turbulence_moisture_flux_for_coupling_to_convection - long_name = turbulence_moisture_flux_for_coupling_to_convection + standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL units = kg kg-1 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real From 761039653da8dd3bc3181ae7d1caa0617720344c Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 22 Apr 2022 14:41:43 +0000 Subject: [PATCH 179/217] Fix issue with dcp test related to CCN prediction --- physics/mp_nssl.F90 | 33 +++++++++------------------------ 1 file changed, 9 insertions(+), 24 deletions(-) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 3f0d136de..c442d204c 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -545,25 +545,16 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN -! cn_mp = Max(0.0, nssl_qccn - Max(0.0,cccn)) - -! DO k = 1,nlev -! DO i = 1,ncol - cn_mp = Max(0.0, nssl_qccn - Max(0.0, cccn_mp) ) -! cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn_mp(i,k)) ) -! cn_mp(i,k) = Min(nssl_qccn, nssl_qccn - cccn(i,k) ) -! ENDDO -! ENDDO - ! DO k = 1,nlev - ! DO i = 1,ncol - ! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) - ! cn_mp(i,k) = cccn(i,k) - ! ENDDO - ! ENDDO + ! cn_mp = Max(0.0, nssl_qccn - Max(0.0,cccn_mp)) + ! Flip CCN concentrations from 'activated' to 'unactivated' (allows BC condition to be zero) + cn_mp = nssl_qccn - cccn_mp + cn_mp = Max(0.0_kind_phys, cn_mp) + ELSE cn_mp = cccn_mp ENDIF IF ( ntccna > 0 ) THEN + ! not in use yet ! cna_mp = cccna ELSE cna_mp = 0 @@ -697,18 +688,12 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN - !cccn = Max(0.0, nssl_qccn - cn_mp ) - cccn_mp = nssl_qccn - cn_mp -! DO k = 1,nlev -! DO i = 1,ncol -! ! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) -! cccn_mp(i,k) = nssl_qccn - cn_mp(i,k) -! ENDDO -! ENDDO + cccn_mp = Max(0.0_kind_phys, nssl_qccn - cn_mp ) +! cccn_mp = nssl_qccn - cn_mp ELSE cccn_mp = cn_mp ENDIF -! cccna = cna_mp +! cccna = cna_mp ! cna not in use yet for ccpp ENDIF ! test code From d5c8c954f574263ce89996be11d5c54e8f4595b1 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 22 Apr 2022 19:29:47 +0000 Subject: [PATCH 180/217] Add haiqin to CODEOWNERS for smoke code --- CODEOWNERS | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CODEOWNERS b/CODEOWNERS index c845e7f97..cf7a886aa 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -11,6 +11,8 @@ # https://docs.google.com/spreadsheets/d/14y0Th_sSpCqlssEMNfSZ_Ni9wrpPqfpPY0kRG7jCZB8/edit#gid=0 # (Internal NOAA document.) +smoke/* @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA + physics/cs_conv_aw_adj.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA physics/cs_conv.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA physics/cu_gf* @hannahcbarnes @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA From df54eaa9b53f7b45cf0c0ae3f7ad69a8bc2c30b6 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Sat, 23 Apr 2022 22:51:46 +0000 Subject: [PATCH 181/217] corrections to merge --- physics/GFS_surface_composites_pre.F90 | 5 ++--- physics/GFS_surface_composites_pre.meta | 14 -------------- physics/mynnpbl_wrapper.F90 | 5 ++--- 3 files changed, 4 insertions(+), 20 deletions(-) diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 index 8e130b229..6139f80dd 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/GFS_surface_composites_pre.F90 @@ -21,7 +21,7 @@ module GFS_surface_composites_pre !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! - subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_cold_start, lkm, frac_grid, & + subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, lkm, frac_grid, & flag_cice, cplflx, cplice, cplwav2atm, lsm, lsm_ruc, & landfrac, lakefrac, lakedepth, oceanfrac, frland, & dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & @@ -35,9 +35,8 @@ subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_co implicit none ! Interface variables - integer, intent(in ) :: im, lkm, kdt integer, intent(in ) :: im, lkm, kdt, lsm, lsm_ruc - logical, intent(in ) :: flag_init, lsm_cold_start, frac_grid, cplflx, cplice, cplwav2atm + logical, intent(in ) :: cplflx, cplice, cplwav2atm, frac_grid logical, dimension(:), intent(inout) :: flag_cice logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet real(kind=kind_phys), dimension(:), intent(in ) :: xlat_d, xlon_d diff --git a/physics/GFS_surface_composites_pre.meta b/physics/GFS_surface_composites_pre.meta index 15259e8b9..e6b437471 100644 --- a/physics/GFS_surface_composites_pre.meta +++ b/physics/GFS_surface_composites_pre.meta @@ -30,20 +30,6 @@ type = real kind = kind_phys intent = in -[lsm_cold_start] - standard_name = do_lsm_cold_start - long_name = flag to signify LSM is cold-started - units = flag - dimensions = () - type = logical - intent = in -[flag_restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart - units = flag - dimensions = () - type = logical - intent = in [lkm] standard_name = control_for_lake_surface_scheme long_name = flag for lake surface model diff --git a/physics/mynnpbl_wrapper.F90 b/physics/mynnpbl_wrapper.F90 index f2858042d..7625b8e9e 100644 --- a/physics/mynnpbl_wrapper.F90 +++ b/physics/mynnpbl_wrapper.F90 @@ -261,12 +261,11 @@ SUBROUTINE mynnedmf_wrapper_run( & & sub_thl,sub_sqv,det_thl,det_sqv real(kind=kind_phys), dimension(:,:), intent(inout) :: & & dqke,qWT,qSHEAR,qBUOY,qDISS + real(kind=kind_phys), dimension(:,:), intent(inout) :: & + & t3d,qgrs_water_vapor,qgrs_liquid_cloud,qgrs_ice_cloud real(kind=kind_phys), dimension(:,:), intent(in) :: & & u,v,omega, & & exner,prsl, & - & qgrs_water_vapor, & - & qgrs_liquid_cloud, & - & qgrs_ice_cloud, & & qgrs_cloud_droplet_num_conc, & & qgrs_cloud_ice_num_conc, & & qgrs_ozone, & From 82075f481c4ad9b89ee9cac311d8e46ec99d61cd Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 25 Apr 2022 18:35:19 -0600 Subject: [PATCH 182/217] Update CMakeLists.txt: update authors, remove custom 'Bitforbit' build mode --- CMakeLists.txt | 16 +++++++--------- physics/module_sf_mynn.F90 | 2 +- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 17ccabebc..f97e4f2f5 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -6,7 +6,7 @@ project(ccpp_physics #------------------------------------------------------------------------------ set(PACKAGE "ccpp-physics") -set(AUTHORS "Grant Firl" "Dom Heinzeller" "Man Zhang" "Laurie Carson") +set(AUTHORS "Grant Firl" "Dom Heinzeller" "Man Zhang" "Mike Kavulich" "Chunxi Zhang") #------------------------------------------------------------------------------ # Set OpenMP flags for C/C++/Fortran @@ -20,7 +20,7 @@ if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) message(STATUS "Setting build type to 'Release' as none was specified.") set(CMAKE_BUILD_TYPE Release CACHE STRING "Choose the type of build." FORCE) # Set the possible values of build type for cmake-gui - set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Bitforbit" "Release" "Coverage") + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" "Coverage") endif() #------------------------------------------------------------------------------ @@ -145,8 +145,7 @@ SET_PROPERTY(SOURCE ${SCHEMES} ${CAPS} APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS}") # Lower optimization for certain schemes when compiling with Intel in Release mode -if((CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND - ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") +if(CMAKE_BUILD_TYPE STREQUAL "Release" AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") # Define a list of schemes that need lower optimization with Intel in Release mode set(SCHEME_NAMES_LOWER_OPTIMIZATION module_sf_mynn.F90) foreach(SCHEME_NAME IN LISTS SCHEME_NAMES_LOWER_OPTIMIZATION) @@ -154,13 +153,13 @@ if((CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit" # Need to determine the name of the scheme with its path list(FILTER SCHEMES_TMP INCLUDE REGEX ".*${SCHEME_NAME}$") SET_SOURCE_FILES_PROPERTIES(${SCHEMES_TMP} - APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS} -O1") + APPEND_STRING PROPERTY COMPILE_FLAGS + " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS} -O1") endforeach() endif() # No optimization for certain schemes when compiling with Intel in Release mode -if((CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND - ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") +if(CMAKE_BUILD_TYPE STREQUAL "Release" AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") # Define a list of schemes that can't be optimized with Intel in Release mode set(SCHEME_NAMES_NO_OPTIMIZATION GFS_typedefs.F90) foreach(SCHEME_NAME IN LISTS SCHEME_NAMES_NO_OPTIMIZATION) @@ -174,8 +173,7 @@ endif() # Reduce optimization for mo_gas_optics_kernels.F90 (to avoid an apparent compiler bug with Intel 19+) if(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 IN_LIST SCHEMES_OPENMP_OFF AND - (CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND - ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") + CMAKE_BUILD_TYPE STREQUAL "Release" AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") SET_SOURCE_FILES_PROPERTIES(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} -O1") endif() diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 5f227750a..22b142c33 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -921,7 +921,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & DO I=its,ite if( flag_iter(i) ) then ! DH* 20200401 - note. A weird bug in Intel 18 on hera prevents using the - ! normal -O2 optimization in REPRO and PROD mode for this file. Not reproducible + ! normal -O2 optimization in Release mode for this file. Not reproducible ! by every user, the bug manifests itself in the resulting wind speed WSPD(I) ! being -99.0 despite the assignments in lines 932 and 933. *DH WSPD(I)=SQRT(U1D(I)*U1D(I)+V1D(I)*V1D(I)) From 89c0c11fbb9559a348ee6dbd949061676e4ee43e Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Apr 2022 16:39:53 +0000 Subject: [PATCH 183/217] Correct issues found by reviewers --- physics/GFS_debug.F90 | 4 +- physics/GFS_rrtmg_pre.meta | 8 +-- physics/GFS_surface_composites_pre.F90 | 3 +- physics/GFS_surface_composites_pre.meta | 16 ------ physics/bl_mynn_common.f90 | 67 ++++++++++++++++++++++++ physics/module_bl_mynn.F90 | 68 ------------------------- physics/module_sf_ruclsm.F90 | 15 ------ physics/mynnpbl_wrapper.meta | 2 +- smoke/rrfs_smoke_wrapper.meta | 8 +-- 9 files changed, 79 insertions(+), 112 deletions(-) create mode 100644 physics/bl_mynn_common.f90 diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index d5ffeaa63..e4278fc45 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -593,9 +593,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvb' , Tbd%acvb) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvt' , Tbd%acvt) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%hpbl' , Tbd%hpbl) - if (Model%imfdeepcnv .ge. 0 .or. Model%imfshalcnv .ge. 0) then + if(Model%imfdeepcnv>0 .or. Model%imfshalcnv>0) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%ud_mf' , Tbd%ud_mf) - end if + endif if (Model%do_sppt) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtdtnp' , Tbd%dtdtnp) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtotprcp' , Tbd%dtotprcp) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index a1839e001..154cb2fab 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1202,16 +1202,16 @@ type = logical intent = in [smoke_ext] - standard_name = smoke_ext - long_name = smoke optical extinction + standard_name = extinction_coefficient_in_air_due_to_smoke + long_name = extinction coefficient in air due to smoke units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in [dust_ext] - standard_name = dust_ext - long_name = dust optical extinction + standard_name = extinction_coefficient_in_air_due_to_dust + long_name = extinction coefficient in air due to dust units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 index 6139f80dd..734f1965b 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/GFS_surface_composites_pre.F90 @@ -21,7 +21,7 @@ module GFS_surface_composites_pre !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! - subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, lkm, frac_grid, & + subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, & flag_cice, cplflx, cplice, cplwav2atm, lsm, lsm_ruc, & landfrac, lakefrac, lakedepth, oceanfrac, frland, & dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & @@ -39,7 +39,6 @@ subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, lkm, frac_grid, logical, intent(in ) :: cplflx, cplice, cplwav2atm, frac_grid logical, dimension(:), intent(inout) :: flag_cice logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet - real(kind=kind_phys), dimension(:), intent(in ) :: xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice real(kind=kind_phys), dimension(:), intent( out) :: frland diff --git a/physics/GFS_surface_composites_pre.meta b/physics/GFS_surface_composites_pre.meta index e6b437471..e87af3e28 100644 --- a/physics/GFS_surface_composites_pre.meta +++ b/physics/GFS_surface_composites_pre.meta @@ -14,22 +14,6 @@ dimensions = () type = integer intent = in -[xlat_d] - standard_name = latitude_in_degree - long_name = latitude in degree north - units = degree_north - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xlon_d] - standard_name = longitude_in_degree - long_name = longitude in degree east - units = degree_east - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [lkm] standard_name = control_for_lake_surface_scheme long_name = flag for lake surface model diff --git a/physics/bl_mynn_common.f90 b/physics/bl_mynn_common.f90 new file mode 100644 index 000000000..7923bbf8b --- /dev/null +++ b/physics/bl_mynn_common.f90 @@ -0,0 +1,67 @@ +!>\file bl_mynn_common.f90 +!! Define Model-specific constants/parameters. +!! This module will be used at the initialization stage +!! where all model-specific constants are read and saved into +!! memory. This module is then used again in the MYNN-EDMF. All +!! MYNN-specific constants are declared globally in the main +!! module (module_bl_mynn) further below: + module bl_mynn_common + +!------------------------------------------ +! +!------------------------------------------ + +! The following 5-6 lines are the only lines in this file that are not +! universal for all dycores... Any ideas how to universalize it? +! For MPAS: +! use mpas_kind_types,only: kind_phys => RKIND +! For CCPP: + use machine, only : kind_phys + + implicit none + save + +! To be specified from dycore + real(kind=kind_phys):: cp != 7.*r_d/2. (J/kg/K) + real(kind=kind_phys):: cpv != 4.*r_v (J/kg/K) Spec heat H2O gas + real(kind=kind_phys):: cice != 2106. (J/kg/K) Spec heat H2O ice + real(kind=kind_phys):: cliq != 4190. (J/kg/K) Spec heat H2O liq + real(kind=kind_phys):: p608 != R_v/R_d-1. + real(kind=kind_phys):: ep_2 != R_d/R_v + real(kind=kind_phys):: grav != accel due to gravity + real(kind=kind_phys):: karman != von Karman constant + real(kind=kind_phys):: t0c != temperature of water at freezing, 273.15 K + real(kind=kind_phys):: rcp != r_d/cp + real(kind=kind_phys):: r_d != 287. (J/kg/K) gas const dry air + real(kind=kind_phys):: r_v != 461.6 (J/kg/K) gas const water + real(kind=kind_phys):: xlf != 0.35E6 (J/kg) fusion at 0 C + real(kind=kind_phys):: xlv != 2.50E6 (J/kg) vaporization at 0 C + real(kind=kind_phys):: xls != 2.85E6 (J/kg) sublimation + real(kind=kind_phys):: rvovrd != r_v/r_d != 1.608 + +! Specified locally + real(kind=kind_phys),parameter:: zero = 0.0 + real(kind=kind_phys),parameter:: half = 0.5 + real(kind=kind_phys),parameter:: one = 1.0 + real(kind=kind_phys),parameter:: two = 2.0 + real(kind=kind_phys),parameter:: onethird = 1./3. + real(kind=kind_phys),parameter:: twothirds = 2./3. + real(kind=kind_phys),parameter:: tref = 300.0 ! reference temperature (K) + real(kind=kind_phys),parameter:: TKmin = 253.0 ! for total water conversion, Tripoli and Cotton (1981) + real(kind=kind_phys),parameter:: p1000mb=100000.0 + real(kind=kind_phys),parameter:: svp1 = 0.6112 !(kPa) + real(kind=kind_phys),parameter:: svp2 = 17.67 !(dimensionless) + real(kind=kind_phys),parameter:: svp3 = 29.65 !(K) + real(kind=kind_phys),parameter:: tice = 240.0 !-33 (C), temp at saturation w.r.t. ice + +! To be derived in the init routine + real(kind=kind_phys):: ep_3 != 1.-ep_2 != 0.378 + real(kind=kind_phys):: gtr != grav/tref + real(kind=kind_phys):: rk != cp/r_d + real(kind=kind_phys):: tv0 != p608*tref + real(kind=kind_phys):: tv1 != (1.+p608)*tref + real(kind=kind_phys):: xlscp != (xlv+xlf)/cp + real(kind=kind_phys):: xlvcp != xlv/cp + real(kind=kind_phys):: g_inv != 1./grav + + end module bl_mynn_common diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index f264cdd3c..409fb3740 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -236,74 +236,6 @@ ! Many of these changes are now documented in references listed above. !==================================================================== - module bl_mynn_common - -!------------------------------------------ -!Define Model-specific constants/parameters. -!This module will be used at the initialization stage -!where all model-specific constants are read and saved into -!memory. This module is then used again in the MYNN-EDMF. All -!MYNN-specific constants are declared globally in the main -!module (module_bl_mynn) further below: -!------------------------------------------ - -! The following 5-6 lines are the only lines in this file that are not -! universal for all dycores... Any ideas how to universalize it? -! For MPAS: -! use mpas_kind_types,only: kind_phys => RKIND -! For CCPP: - use machine, only : kind_phys - - implicit none - save - -! To be specified from dycore - real(kind=kind_phys):: cp != 7.*r_d/2. (J/kg/K) - real(kind=kind_phys):: cpv != 4.*r_v (J/kg/K) Spec heat H2O gas - real(kind=kind_phys):: cice != 2106. (J/kg/K) Spec heat H2O ice - real(kind=kind_phys):: cliq != 4190. (J/kg/K) Spec heat H2O liq - real(kind=kind_phys):: p608 != R_v/R_d-1. - real(kind=kind_phys):: ep_2 != R_d/R_v - real(kind=kind_phys):: grav != accel due to gravity - real(kind=kind_phys):: karman != von Karman constant - real(kind=kind_phys):: t0c != temperature of water at freezing, 273.15 K - real(kind=kind_phys):: rcp != r_d/cp - real(kind=kind_phys):: r_d != 287. (J/kg/K) gas const dry air - real(kind=kind_phys):: r_v != 461.6 (J/kg/K) gas const water - real(kind=kind_phys):: xlf != 0.35E6 (J/kg) fusion at 0 C - real(kind=kind_phys):: xlv != 2.50E6 (J/kg) vaporization at 0 C - real(kind=kind_phys):: xls != 2.85E6 (J/kg) sublimation - real(kind=kind_phys):: rvovrd != r_v/r_d != 1.608 - -! Specified locally - real(kind=kind_phys),parameter:: zero = 0.0 - real(kind=kind_phys),parameter:: half = 0.5 - real(kind=kind_phys),parameter:: one = 1.0 - real(kind=kind_phys),parameter:: two = 2.0 - real(kind=kind_phys),parameter:: onethird = 1./3. - real(kind=kind_phys),parameter:: twothirds = 2./3. - real(kind=kind_phys),parameter:: tref = 300.0 ! reference temperature (K) - real(kind=kind_phys),parameter:: TKmin = 253.0 ! for total water conversion, Tripoli and Cotton (1981) - real(kind=kind_phys),parameter:: p1000mb=100000.0 - real(kind=kind_phys),parameter:: svp1 = 0.6112 !(kPa) - real(kind=kind_phys),parameter:: svp2 = 17.67 !(dimensionless) - real(kind=kind_phys),parameter:: svp3 = 29.65 !(K) - real(kind=kind_phys),parameter:: tice = 240.0 !-33 (C), temp at saturation w.r.t. ice - -! To be derived in the init routine - real(kind=kind_phys):: ep_3 != 1.-ep_2 != 0.378 - real(kind=kind_phys):: gtr != grav/tref - real(kind=kind_phys):: rk != cp/r_d - real(kind=kind_phys):: tv0 != p608*tref - real(kind=kind_phys):: tv1 != (1.+p608)*tref - real(kind=kind_phys):: xlscp != (xlv+xlf)/cp - real(kind=kind_phys):: xlvcp != xlv/cp - real(kind=kind_phys):: g_inv != 1./grav - - end module bl_mynn_common - -!================================================================== - MODULE module_bl_mynn use bl_mynn_common,only: & diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 01e9c1100..0cf820303 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -2581,21 +2581,6 @@ SUBROUTINE SOIL (debug_print, & ! print *,'alfa=',alfa, exp(G0_P*psit/r_v/SOILT) ! endif alfa=1. -! field capacity -! 20jun18 - beta in Eq. (5) is called soilres in the code - it limits soil evaporation -! when soil moisture is below field capacity. [Lee and Pielke, 1992] -! This formulation agrees with obsevations when top layer is < 2 cm thick. -! Soilres = 1 for snow, glaciers and wetland. -! fc=ref - suggested in the paper -! fc=max(qmin,ref*0.5) ! used prior to 20jun18 change -! Switch from ref*0.5 to ref*0.25 will reduce soil resistance, increase direct -! evaporation, effects sparsely vegetated areas--> cooler during the day -! fc=max(qmin,ref*0.25) ! -! For now we'll go back to ref*0.5 -! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct -! evaporation. Therefore , it is replaced with ref*0.7. - !fc=max(qmin,ref*0.5) - !fc=max(qmin,ref*0.7) fc=ref fex_fc=1. if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then diff --git a/physics/mynnpbl_wrapper.meta b/physics/mynnpbl_wrapper.meta index 4b52c6e8d..4377ffce8 100644 --- a/physics/mynnpbl_wrapper.meta +++ b/physics/mynnpbl_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mynnedmf_wrapper type = scheme - dependencies = machine.F,module_bl_mynn.F90,physcons.F90 + dependencies = machine.F,module_bl_mynn.F90,physcons.F90,bl_mynn_common.f90 ######################################################################## [ccpp-arg-table] diff --git a/smoke/rrfs_smoke_wrapper.meta b/smoke/rrfs_smoke_wrapper.meta index 867550f50..c96a8b17a 100755 --- a/smoke/rrfs_smoke_wrapper.meta +++ b/smoke/rrfs_smoke_wrapper.meta @@ -530,16 +530,16 @@ kind = kind_phys intent = out [smoke_ext] - standard_name = smoke_ext - long_name = smoke optical extinction + standard_name = extinction_coefficient_in_air_due_to_smoke + long_name = extinction coefficient in air due to smoke units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = out [dust_ext] - standard_name = dust_ext - long_name = dust optical extinction + standard_name = extinction_coefficient_in_air_due_to_dust + long_name = extinction coefficient in air due to dust units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real From 86022b3104278c7f0df217293dbaba6f43cbeff2 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Apr 2022 17:42:59 +0000 Subject: [PATCH 184/217] Rename mynnpbl to mynnedmf --- physics/GFS_debug.F90 | 2 +- physics/GFS_rrtmg_pre.F90 | 1 + physics/{mynnpbl_wrapper.F90 => mynnedmf_wrapper.F90} | 2 +- physics/{mynnpbl_wrapper.meta => mynnedmf_wrapper.meta} | 4 ++-- 4 files changed, 5 insertions(+), 4 deletions(-) rename physics/{mynnpbl_wrapper.F90 => mynnedmf_wrapper.F90} (99%) rename physics/{mynnpbl_wrapper.meta => mynnedmf_wrapper.meta} (99%) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index e4278fc45..ef1a8003f 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -726,7 +726,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, end if call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dkt ', Diag%dkt) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dku ', Diag%dku) - ! CCPP/MYNNPBL only + ! CCPP/MYNNEDMF only if (Model%do_mynnedmf) then if (Model%bl_mynn_output .ne. 0) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%edmf_a ', Diag%edmf_a) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index f1b0027ac..57261ef18 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -619,6 +619,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo + !> Aerosol direct feedback effect by smoke and dust if(aero_dir_fdb) then ! add smoke/dust extinctions do k = 1, LMK do i = 1, IM diff --git a/physics/mynnpbl_wrapper.F90 b/physics/mynnedmf_wrapper.F90 similarity index 99% rename from physics/mynnpbl_wrapper.F90 rename to physics/mynnedmf_wrapper.F90 index 7625b8e9e..744a07e51 100644 --- a/physics/mynnpbl_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -1,4 +1,4 @@ -!> \file MYNNPBL_wrapper.F90 +!> \file mynnedmf_wrapper.F90 !! This file contains all of the code related to running the MYNN !! eddy-diffusivity mass-flux scheme. diff --git a/physics/mynnpbl_wrapper.meta b/physics/mynnedmf_wrapper.meta similarity index 99% rename from physics/mynnpbl_wrapper.meta rename to physics/mynnedmf_wrapper.meta index 4377ffce8..7fbb85311 100644 --- a/physics/mynnpbl_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -781,7 +781,7 @@ kind = kind_phys intent = inout [exch_h] - standard_name = atmosphere_heat_diffusivity_for_mynnpbl + standard_name = atmosphere_heat_diffusivity_for_mynnedmf long_name = diffusivity for heat for MYNN PBL (defined for all mass levels) units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -789,7 +789,7 @@ kind = kind_phys intent = out [exch_m] - standard_name = atmosphere_momentum_diffusivity_for_mynnpbl + standard_name = atmosphere_momentum_diffusivity_for_mynnedmf long_name = diffusivity for momentum for MYNN PBL (defined for all mass levels) units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) From 0200e2d05757af34a070e52fe8558ecbaa73a42a Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Wed, 27 Apr 2022 18:48:38 +0000 Subject: [PATCH 185/217] addressing some review comments --- physics/progsigma_calc.f90 | 2 +- physics/samfdeepcnv.f | 2 +- physics/samfdeepcnv.meta | 2 +- physics/samfshalcnv.f | 2 +- physics/samfshalcnv.meta | 2 +- physics/satmedmfvdifq.F | 25 ++++++++++++++++++++----- physics/satmedmfvdifq.meta | 7 +++++++ 7 files changed, 32 insertions(+), 10 deletions(-) diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index 58a6fc0ef..55f6b5e3a 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -180,7 +180,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & form(i,k)=-1.0*inbu(i,k)*(omega_u(i,k)*delt) fdqb=0.5*((form(i,k)*zdqca(i,k))) termC(i)=termC(i)+inbu(i,k)* & - (fdqb+fdqa(i))*hvap*zeta(i,k)) + (fdqb+fdqa(i))*hvap*zeta(i,k) fdqa(i)=fdqb endif enddo diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index f8a60a5e3..5fd54a2ec 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -79,7 +79,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & tmf,qmicro,itc,ntc,cliq,cp,cvap, & & eps,epsm1,fv,grav,hvap,rd,rv, & & t0c,delt,ntk,ntr,delp, & - & prslp,psp,phil,qtr,prevsq,q,q1,t1,u1,v1,fscav, & + & prslp,psp,phil,qtr,prevsq,q,q1,t1,u1,v1,fscav, & & hwrf_samfdeep,progsigma,wclosureflg,cldwrk,rn,kbot,ktop,kcnv, & & islimsk,garea,dot,ncloud,hpbl,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & & QLCN, QICN, w_upi, cf_upi, CNV_MFD, & diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index e956d24ed..2b2942812 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -78,7 +78,7 @@ kind = kind_phys intent = in [qmicro] - standard_name = instantaneous_moisture_tendency_due_to_microphysics + standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics long_name = moisture tendency due to microphysics units = kg kg-1 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 56571457a..325566877 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -59,7 +59,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & eps,epsm1,fv,grav,hvap,rd,rv, & & t0c,delt,ntk,ntr,delp,first_time_step,restart, & & tmf,qmicro,progsigma, & - & prslp,psp,phil,qtr,prevsq,q,q1,t1,u1,v1,fscav, & + & prslp,psp,phil,qtr,prevsq,q,q1,t1,u1,v1,fscav, & & rn,kbot,ktop,kcnv,islimsk,garea, & & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, & & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal, diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index a4cca64b8..8c9735c32 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -78,7 +78,7 @@ kind = kind_phys intent = in [qmicro] - standard_name = instantaneous_moisture_tendency_due_to_microphysics + standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics long_name = moisture tendency due to microphysics units = kg kg-1 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 0fce7dd9a..c7a6fadc9 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -67,8 +67,8 @@ end subroutine satmedmfvdifq_finalize !! (mfscuq.f). !! \section detail_satmedmfvidfq GFS satmedmfvdifq Detailed Algorithm !! @{ - subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & - & grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & + subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & + & ntiw,ntke,grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & & dv,du,tdt,rtg,tmf,u1,v1,t1,q1,swh,hlw,xmu,garea,zvfun, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & @@ -91,7 +91,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & integer, intent(in) :: sfc_rlm integer, intent(in) :: kinver(:) integer, intent(out) :: kpbl(:) - logical, intent(in) :: gen_tend,ldiag3d + logical, intent(in) :: gen_tend,ldiag3d,progsigma ! real(kind=kind_phys), intent(in) :: grav,rd,cp,rv,hvap,hfus,fv, & & eps,epsm1 @@ -299,7 +299,6 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & xmfd(i,k) = 0. buou(i,k) = 0. buod(i,k) = 0. - tmf(i,k) = 0. ckz(i,k) = ck1 chz(i,k) = ch1 rlmnz(i,k) = rlmn0 @@ -313,6 +312,14 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & zm(i,k) = zi(i,k+1) enddo enddo +!> - Initialize variables needed for prognostic cumulus closure + if(progsigma)then + do k=1,km + do i=1,im + tmf(i,k) = 0. + enddo + enddo + endif !> - Compute horizontal grid size (\p gdx) do i=1,im gdx(i) = sqrt(garea(i)) @@ -2115,11 +2122,19 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & qtend = (f2(i,k)-q1(i,k,1))*rdt tdt(i,k) = tdt(i,k)+ttend rtg(i,k,1) = rtg(i,k,1)+qtend - tmf(i,k) = qtend ! dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend ! dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend enddo enddo + + if(progsigma)then + do k = 1,km + do i = 1,im + tmf(i,k)=(f2(i,k)-q1(i,k,1))*rdt + enddo + enddo + endif + do i = 1,im dtsfc(i) = rho_a(i) * cp * heat(i) dqsfc(i) = rho_a(i) * hvap * evap(i) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index fa30cd9f7..88ab676b8 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -62,6 +62,13 @@ dimensions = () type = integer intent = in +[progsigma] + standard_name = do_prognostic_updraft_area_fraction + long_name = flag for prognostic sigma in cumuls scheme + units = flag + dimensions = () + type = logical + intent = in [ntrac] standard_name = number_of_vertical_diffusion_tracers long_name = number of tracers to diffuse vertically From 900e2c3e1f3a4aa82c35ad99f9456edd56c6599c Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Apr 2022 21:28:30 +0000 Subject: [PATCH 186/217] Remove some empty _init and _finalize routines and update a comment in sgscloud_radpre --- physics/sgscloud_radpre.F90 | 11 +++++++---- smoke/rrfs_smoke_lsdep_wrapper.F90 | 14 +------------- smoke/rrfs_smoke_lsdep_wrapper.meta | 10 ---------- smoke/rrfs_smoke_postpbl.F90 | 14 +------------- smoke/rrfs_smoke_postpbl.meta | 10 ---------- smoke/rrfs_smoke_wrapper.F90 | 14 +------------- smoke/rrfs_smoke_wrapper.meta | 10 ---------- 7 files changed, 10 insertions(+), 73 deletions(-) diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index 1b63c5471..6567a331b 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -23,10 +23,13 @@ end subroutine sgscloud_radpre_init subroutine sgscloud_radpre_finalize () end subroutine sgscloud_radpre_finalize -!> This interstitial code adds the subgrid clouds to the resolved-scale clouds -!! if there is no resolved-scale clouds in that particular grid box. It can also -!! specify a cloud fraction for resolved-scale clouds, using Xu-Randall (1996), -!! if desired. +!> This interstitial code adds the subgrid clouds to the resolved-scale clouds +!! if there is no resolved-scale clouds in that particular grid box. It can also +!! specify a cloud fraction for resolved-scale clouds as is done currently when +!! using MYNN-EDMF. For clouds coming from the convection schemes (in this case +!! only used by GF scheme), two cloud fraction options are available: +!! Xu-Randall (XR1996) or Chaboureau and Bechtold (CB2005), chosen by the +!! switch "conv_cf_opt" = 0: CB2005, 1: XR1996. !> \section arg_table_sgscloud_radpre_run Argument Table !! \htmlinclude sgscloud_radpre_run.html !! diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/smoke/rrfs_smoke_lsdep_wrapper.F90 index 8625fe844..d4aa1323b 100644 --- a/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ b/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -15,22 +15,10 @@ module rrfs_smoke_lsdep_wrapper private - public :: rrfs_smoke_lsdep_wrapper_init, rrfs_smoke_lsdep_wrapper_run, rrfs_smoke_lsdep_wrapper_finalize + public :: rrfs_smoke_lsdep_wrapper_run contains -!> \brief Brief description of the subroutine -!! - subroutine rrfs_smoke_lsdep_wrapper_init() - end subroutine rrfs_smoke_lsdep_wrapper_init - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_rrfs_smoke_lsdep_wrapper_finalize Argument Table -!! - subroutine rrfs_smoke_lsdep_wrapper_finalize() - end subroutine rrfs_smoke_lsdep_wrapper_finalize - !> \defgroup gsd_chem_group GSD Chem driver Module !! This is the gsd chemistry !>\defgroup rrfs_smoke_lsdep_wrapper GSD Chem driver Module diff --git a/smoke/rrfs_smoke_lsdep_wrapper.meta b/smoke/rrfs_smoke_lsdep_wrapper.meta index 7766ab2c4..8a9ff5462 100755 --- a/smoke/rrfs_smoke_lsdep_wrapper.meta +++ b/smoke/rrfs_smoke_lsdep_wrapper.meta @@ -3,16 +3,6 @@ type = scheme dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_lsdep_wrapper_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_lsdep_wrapper_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = rrfs_smoke_lsdep_wrapper_run diff --git a/smoke/rrfs_smoke_postpbl.F90 b/smoke/rrfs_smoke_postpbl.F90 index 02ed273ae..e58f3d49b 100755 --- a/smoke/rrfs_smoke_postpbl.F90 +++ b/smoke/rrfs_smoke_postpbl.F90 @@ -11,22 +11,10 @@ module rrfs_smoke_postpbl private - public :: rrfs_smoke_postpbl_init, rrfs_smoke_postpbl_run, rrfs_smoke_postpbl_finalize + public :: rrfs_smoke_postpbl_run contains -!> \brief Brief description of the subroutine -!! - subroutine rrfs_smoke_postpbl_init() - end subroutine rrfs_smoke_postpbl_init - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_rrfs_smoke_postpbl_finalize Argument Table -!! - subroutine rrfs_smoke_postpbl_finalize() - end subroutine rrfs_smoke_postpbl_finalize - !> \defgroup gsd_chem_group GSD Chem emission driver Module !! This is the gsd chemistry !>\defgroup rrfs_smoke_postpbl GSD Chem emission driver Module diff --git a/smoke/rrfs_smoke_postpbl.meta b/smoke/rrfs_smoke_postpbl.meta index e9597adc8..45ca60cb4 100755 --- a/smoke/rrfs_smoke_postpbl.meta +++ b/smoke/rrfs_smoke_postpbl.meta @@ -3,16 +3,6 @@ type = scheme dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_wrapper_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_wrapper_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = rrfs_smoke_wrapper_run diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 index 7b2cda56b..105594cb5 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -20,22 +20,10 @@ module rrfs_smoke_wrapper private - public :: rrfs_smoke_wrapper_init, rrfs_smoke_wrapper_run, rrfs_smoke_wrapper_finalize + public :: rrfs_smoke_wrapper_run contains -!> \brief Brief description of the subroutine -!! - subroutine rrfs_smoke_wrapper_init() - end subroutine rrfs_smoke_wrapper_init - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_rrfs_smoke_wrapper_finalize Argument Table -!! - subroutine rrfs_smoke_wrapper_finalize() - end subroutine rrfs_smoke_wrapper_finalize - !> \defgroup gsd_chem_group GSD Chem emission driver Module !! This is the gsd chemistry !>\defgroup rrfs_smoke_wrapper GSD Chem emission driver Module diff --git a/smoke/rrfs_smoke_wrapper.meta b/smoke/rrfs_smoke_wrapper.meta index c96a8b17a..709ea00d1 100755 --- a/smoke/rrfs_smoke_wrapper.meta +++ b/smoke/rrfs_smoke_wrapper.meta @@ -3,16 +3,6 @@ type = scheme dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_wrapper_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_wrapper_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = rrfs_smoke_wrapper_run From e2d5a2a6310a3aa8313ba9c65ff29dc16bf6b954 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Wed, 27 Apr 2022 22:40:40 +0000 Subject: [PATCH 187/217] cleaning out some print statements --- physics/progsigma_calc.f90 | 12 ++++++------ physics/samfdeepcnv.f | 36 +++++++++++++++++++++++------------- physics/samfdeepcnv.meta | 15 ++++++++------- 3 files changed, 37 insertions(+), 26 deletions(-) diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index 55f6b5e3a..21612fd6c 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -43,7 +43,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & integer :: i,k,km1 real(kind=kind_phys) :: termA(im),termB(im),termC(im),termD(im), & mcons(im),fdqa(im),form(im,km), & - qadv(im,km),sigmamax(im),dp(im),inbu(im,km) + qadv(im,km),sigmamax(im),dp(im,km),inbu(im,km) real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, & @@ -82,7 +82,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do k = 2,km1 do i = 1,im if(cnvflg(i))then - dp(i) = 1000. * del(i,k) + dp(i,k) = 1000. * del(i,k) endif enddo enddo @@ -128,7 +128,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & endif enddo enddo - + !compute termD "The vertical integral of the latent heat convergence is limited to the !buoyant layers with positive moisture convergence (accumulated from the surface). !Lowest level: @@ -140,7 +140,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do k = 2,km1 do i = 1,im if(cnvflg(i))then - mcon = (hvap*(qadv(i,k)+tmf(i,k)+qmicro(i,k))*dp(i)) + mcon = (hvap*(qadv(i,k)+tmf(i,k)+qmicro(i,k))*dp(i,k)) buy2 = termD(i)+mcon+mcons(i) ! Do the integral over buoyant layers with positive mcon acc from surface if(k > kbcon1(i) .and. k < ktcon(i) .and. buy2 > 0.)then @@ -157,7 +157,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do k = 2,km1 do i = 1,im if(cnvflg(i))then - tem=(sigmab(i)*zeta(i,k)*inbu(i,k)*dbyo1(i,k))*dp(i) + tem=(sigmab(i)*zeta(i,k)*inbu(i,k)*dbyo1(i,k))*dp(i,k) termA(i)=termA(i)+tem endif enddo @@ -167,7 +167,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do k = 2,km1 do i = 1,im if(cnvflg(i))then - tem=(dbyo1(i,k)*inbu(i,k))*dp(i) + tem=(dbyo1(i,k)*inbu(i,k))*dp(i,k) termB(i)=termB(i)+tem endif enddo diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 5fd54a2ec..bf48d2035 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -80,13 +80,13 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & eps,epsm1,fv,grav,hvap,rd,rv, & & t0c,delt,ntk,ntr,delp, & & prslp,psp,phil,qtr,prevsq,q,q1,t1,u1,v1,fscav, & - & hwrf_samfdeep,progsigma,wclosureflg,cldwrk,rn,kbot,ktop,kcnv, & + & hwrf_samfdeep,progsigma,cldwrk,rn,kbot,ktop,kcnv, & & islimsk,garea,dot,ncloud,hpbl,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & & QLCN, QICN, w_upi, cf_upi, CNV_MFD, & & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys,mp_phys_mg,& & clam,c0s,c1,betal,betas,evef,pgcon,asolfac, & & do_ca, ca_closure, ca_entr, ca_trigger, nthresh, ca_deep, & - & rainevap, sigmain, sigmaout, & + & rainevap, sigmain, sigmaout, ca_micro, & & errmsg,errflg) ! use machine , only : kind_phys @@ -103,12 +103,12 @@ 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, wclosureflg + & progsigma real(kind=kind_phys), intent(in) :: nthresh real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & & tmf(:,:),q(:,:), prevsq(:,:) - real(kind=kind_phys), intent(out) :: rainevap(:) + real(kind=kind_phys), intent(out) :: rainevap(:), ca_micro(:) real(kind=kind_phys), intent(out) :: sigmaout(:,:) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger @@ -243,7 +243,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! parameter(cinacrmx=-120.,cinacrmn=-120.) parameter(cinacrmx=-120.,cinacrmn=-80.) parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) - parameter(betaw=.03,dxcrtas=8.e3,dxcrtuf=15.e3) + parameter(betaw=.03,dxcrtuf=15.e3) ! ! local variables and arrays @@ -380,6 +380,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & advfac(i) = 0. rainevap(i) = 0. omegac(i)=0. + ca_micro(i)=0. gdx(i) = sqrt(garea(i)) enddo @@ -2456,8 +2457,15 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & c c------- final changed variable per unit mass flux c -!> - If grid size is less than a threshold value (dxcrtas: currently 8km), the quasi-equilibrium assumption of Arakawa-Schubert is not used any longer. +!> - If grid size is less than a threshold value (dxcrtas: currently 8km if progsigma is not used and 30km if progsigma is used), the quasi-equilibrium assumption of Arakawa-Schubert is not used any longer. ! + if(progsigma)then + dxcrtas=30.e3 + else + dxcrtas=8.e3 + endif + + do i = 1, im asqecflg(i) = cnvflg(i) if(asqecflg(i) .and. gdx(i) < dxcrtas) then @@ -2465,13 +2473,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & endif enddo -!> - If wclosureflg is true, then quasi-equilibrium closure of Arakawa-Schubert is not used any longer, regardless of resolution - if(wclosureflg)then - do i = 1, im - asqecflg(i) = .false. - enddo - endif - ! !> - If grid size is larger than the threshold value (i.e., asqecflg=.true.), the quasi-equilibrium assumption is used to obtain the cloud base mass flux. To begin with, calculate the change in the temperature and moisture profiles per unit cloud base mass flux. do k = 1, km @@ -2884,6 +2885,15 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. + + if(progsigma)then + do i= 1, im + if(cnvflg(i))then + ca_micro(i)=sigmab(i) + endif + enddo + endif + do i= 1, im if(cnvflg(i) .and. .not.asqecflg(i)) then k = kbcon(i) diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 2b2942812..5e589b318 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -312,13 +312,6 @@ dimensions = () type = logical intent = in -[wclosureflg] - standard_name = flag_for_wclosure - long_name = flag for vertical velocity closure - units = flag - dimensions = () - type = logical - intent = in [progsigma] standard_name = do_prognostic_updraft_area_fraction long_name = flag for prognostic sigma in cumuls scheme @@ -667,6 +660,14 @@ type = real kind = kind_phys intent = out +[ca_micro] + standard_name = output_prognostic_sigma_two + long_name = output of prognostic area fraction two + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 3fba412336314ac008ed70a45d85e17024dd7cef Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 28 Apr 2022 23:29:39 +0000 Subject: [PATCH 188/217] Add \file to smoke files --- smoke/dep_dry_gocart_mod.F90 | 4 ++++ smoke/dep_dry_mod.F90 | 3 +++ smoke/dep_simple_mod.F90 | 3 +++ smoke/dep_vertmx_mod.F90 | 3 +++ smoke/dep_wet_ls_mod.F90 | 3 +++ smoke/dust_data_mod.F90 | 3 +++ smoke/dust_fengsha_mod.F90 | 3 +++ smoke/module_add_emiss_burn.F90 | 3 +++ smoke/module_plumerise1.F90 | 3 +++ smoke/module_smoke_plumerise.F90 | 3 +++ smoke/module_zero_plumegen_coms.F90 | 3 +++ smoke/plume_data_mod.F90 | 3 +++ smoke/rrfs_smoke_config.F90 | 4 +++- smoke/rrfs_smoke_data.F90 | 3 +++ smoke/rrfs_smoke_lsdep_wrapper.F90 | 2 -- smoke/rrfs_smoke_postpbl.F90 | 2 -- smoke/rrfs_smoke_wrapper.F90 | 2 -- smoke/seas_data_mod.F90 | 3 +++ smoke/seas_mod.F90 | 3 +++ smoke/seas_ngac_mod.F90 | 3 +++ 20 files changed, 52 insertions(+), 7 deletions(-) diff --git a/smoke/dep_dry_gocart_mod.F90 b/smoke/dep_dry_gocart_mod.F90 index 6e15f2e57..9fb5edfd1 100755 --- a/smoke/dep_dry_gocart_mod.F90 +++ b/smoke/dep_dry_gocart_mod.F90 @@ -1,3 +1,7 @@ +!>\file dep_dry_gocart_mod.F90 +!! This file is GOCART dry deposition module to calculate the dry deposition +!! velocities of smoke and dust. + module dep_dry_gocart_mod use machine , only : kind_phys diff --git a/smoke/dep_dry_mod.F90 b/smoke/dep_dry_mod.F90 index 140db6002..9520d2897 100755 --- a/smoke/dep_dry_mod.F90 +++ b/smoke/dep_dry_mod.F90 @@ -1,3 +1,6 @@ +!>\file dep_dry_mod.F90 +!! This file is for the dry depostion driver. + module dep_dry_mod use machine , only : kind_phys diff --git a/smoke/dep_simple_mod.F90 b/smoke/dep_simple_mod.F90 index 9751b19a6..37a8189b5 100755 --- a/smoke/dep_simple_mod.F90 +++ b/smoke/dep_simple_mod.F90 @@ -1,3 +1,6 @@ +!>\file dep_simple_mod.F90 +!! This file contains the Wesely dry deposition module. + module dep_simple_mod use rrfs_smoke_data diff --git a/smoke/dep_vertmx_mod.F90 b/smoke/dep_vertmx_mod.F90 index 5933af271..d56b1b87e 100755 --- a/smoke/dep_vertmx_mod.F90 +++ b/smoke/dep_vertmx_mod.F90 @@ -1,3 +1,6 @@ +!>\file dep_vertmx_mod.F90 +!! This file calculates change in time of phi due to vertical mixing and dry deposition. + MODULE dep_vertmx_mod use rrfs_smoke_data use machine , only : kind_phys diff --git a/smoke/dep_wet_ls_mod.F90 b/smoke/dep_wet_ls_mod.F90 index bfbe275f2..23ceb803e 100755 --- a/smoke/dep_wet_ls_mod.F90 +++ b/smoke/dep_wet_ls_mod.F90 @@ -1,3 +1,6 @@ +!>\file dep_wet_ls_mod.F90 +!! This file contains aerosol wet deposition module. + module dep_wet_ls_mod use rrfs_smoke_data use machine , only : kind_phys diff --git a/smoke/dust_data_mod.F90 b/smoke/dust_data_mod.F90 index 33767701b..9e9713e22 100755 --- a/smoke/dust_data_mod.F90 +++ b/smoke/dust_data_mod.F90 @@ -1,3 +1,6 @@ +!>\file dust_data_mod.F90 +!! This file contains the data for the dust flux schemes. + module dust_data_mod use rrfs_smoke_data diff --git a/smoke/dust_fengsha_mod.F90 b/smoke/dust_fengsha_mod.F90 index c43719386..fbf87aa56 100755 --- a/smoke/dust_fengsha_mod.F90 +++ b/smoke/dust_fengsha_mod.F90 @@ -1,3 +1,6 @@ +!>\file dust_fengsha_mod.F90 +!! This file contains the FENGSHA dust scheme. + module dust_fengsha_mod ! ! This module developed by Barry Baker (NOAA ARL) diff --git a/smoke/module_add_emiss_burn.F90 b/smoke/module_add_emiss_burn.F90 index 5d5e63b21..da35535f7 100755 --- a/smoke/module_add_emiss_burn.F90 +++ b/smoke/module_add_emiss_burn.F90 @@ -1,3 +1,6 @@ +!>\file module_add_emiss_burn.F90 +!! This file adds the biomass burning emissions to the smoke field. + module module_add_emiss_burn !RAR: significantly modified for the new BB emissions use machine , only : kind_phys diff --git a/smoke/module_plumerise1.F90 b/smoke/module_plumerise1.F90 index ea2c4e3f7..f3c756b7e 100755 --- a/smoke/module_plumerise1.F90 +++ b/smoke/module_plumerise1.F90 @@ -1,3 +1,6 @@ +!>\file module_plumerise1.F90 +!! This file is the fire plume rise driver. + module module_plumerise1 use rrfs_smoke_data diff --git a/smoke/module_smoke_plumerise.F90 b/smoke/module_smoke_plumerise.F90 index f31759404..a9535f8b1 100755 --- a/smoke/module_smoke_plumerise.F90 +++ b/smoke/module_smoke_plumerise.F90 @@ -1,3 +1,6 @@ +!>\file module_smoke_plumerise.F90 +!! This file contains the fire plume rise module. + !------------------------------------------------------------------------- !- 12 April 2016 !- Implementing the fire radiative power (FRP) methodology for biomass burning diff --git a/smoke/module_zero_plumegen_coms.F90 b/smoke/module_zero_plumegen_coms.F90 index d00554753..622d6a813 100755 --- a/smoke/module_zero_plumegen_coms.F90 +++ b/smoke/module_zero_plumegen_coms.F90 @@ -1,3 +1,6 @@ +!>\file module_zero_plumegen_coms.F90 +!! This module initilizes variables for the fire plume rise scheme. + module module_zero_plumegen_coms use machine , only : kind_phys diff --git a/smoke/plume_data_mod.F90 b/smoke/plume_data_mod.F90 index ce89dc4fd..3d4b21c37 100755 --- a/smoke/plume_data_mod.F90 +++ b/smoke/plume_data_mod.F90 @@ -1,3 +1,6 @@ +!>\file plume_data_mod.F90 +!! This file contains data for the fire plume rise module. + module plume_data_mod use machine , only : kind_phys diff --git a/smoke/rrfs_smoke_config.F90 b/smoke/rrfs_smoke_config.F90 index f3cdd13c9..43b3aee14 100755 --- a/smoke/rrfs_smoke_config.F90 +++ b/smoke/rrfs_smoke_config.F90 @@ -1,8 +1,10 @@ +!>\file rrfs_smoke_config.F90 +!! This file contains the configuration for RRFS-Smoke. ! ! Haiqin.Li@noaa.gov ! 06/2021 ! constant parameters and chemistry configurations and tracers -! (This will be splited into three subroutine for configuration, constant and tracers later) +! (This will be splited into three subroutines for configuration, constant and tracers later) ! 06/2021 move configuration into chem nml ! module rrfs_smoke_config diff --git a/smoke/rrfs_smoke_data.F90 b/smoke/rrfs_smoke_data.F90 index b5dbf5199..f1d11960a 100755 --- a/smoke/rrfs_smoke_data.F90 +++ b/smoke/rrfs_smoke_data.F90 @@ -1,3 +1,6 @@ +!>\file rrfs_smoke_data.F90 +!! This file contains data for the RRFS-Smoke modules. + module rrfs_smoke_data use machine , only : kind_phys implicit none diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/smoke/rrfs_smoke_lsdep_wrapper.F90 index d4aa1323b..d64866f41 100644 --- a/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ b/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -19,8 +19,6 @@ module rrfs_smoke_lsdep_wrapper contains -!> \defgroup gsd_chem_group GSD Chem driver Module -!! This is the gsd chemistry !>\defgroup rrfs_smoke_lsdep_wrapper GSD Chem driver Module !> \ingroup gsd_chem_group !! This is the GSD Chem driver Module diff --git a/smoke/rrfs_smoke_postpbl.F90 b/smoke/rrfs_smoke_postpbl.F90 index e58f3d49b..b9d61d42b 100755 --- a/smoke/rrfs_smoke_postpbl.F90 +++ b/smoke/rrfs_smoke_postpbl.F90 @@ -15,8 +15,6 @@ module rrfs_smoke_postpbl contains -!> \defgroup gsd_chem_group GSD Chem emission driver Module -!! This is the gsd chemistry !>\defgroup rrfs_smoke_postpbl GSD Chem emission driver Module !> \ingroup gsd_chem_group !! This is the GSD Chem emission driver Module diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 index 105594cb5..a179553b6 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -24,8 +24,6 @@ module rrfs_smoke_wrapper contains -!> \defgroup gsd_chem_group GSD Chem emission driver Module -!! This is the gsd chemistry !>\defgroup rrfs_smoke_wrapper GSD Chem emission driver Module !> \ingroup gsd_chem_group !! This is the GSD Chem emission driver Module diff --git a/smoke/seas_data_mod.F90 b/smoke/seas_data_mod.F90 index 6602d58a2..a6f451c39 100755 --- a/smoke/seas_data_mod.F90 +++ b/smoke/seas_data_mod.F90 @@ -1,3 +1,6 @@ +!>\file seas_data_mod.F90 +!! This file contains data for the sea salt emission modules. + module seas_data_mod use machine , only : kind_phys diff --git a/smoke/seas_mod.F90 b/smoke/seas_mod.F90 index a610884d6..78bcef5be 100755 --- a/smoke/seas_mod.F90 +++ b/smoke/seas_mod.F90 @@ -1,3 +1,6 @@ +!>\file seas_mod.F90 +!! This file contains the sea salt emission module. + module seas_mod use machine , only : kind_phys diff --git a/smoke/seas_ngac_mod.F90 b/smoke/seas_ngac_mod.F90 index 73605ecc1..411635db2 100755 --- a/smoke/seas_ngac_mod.F90 +++ b/smoke/seas_ngac_mod.F90 @@ -1,3 +1,6 @@ +!>\file seas_ngac_mod.F90 +!! This file contains the ngac sea-salt module. + !------------------------------------------------------------------------- ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! ! Adapted by NOAA/GSD/ESRL ! From 8b815e026ddcd8e660e437dc94bb89058e6f80de Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Fri, 29 Apr 2022 03:03:46 +0000 Subject: [PATCH 189/217] address some bugs caught by debug flag --- physics/progsigma_calc.f90 | 11 ++++++----- physics/samfdeepcnv.f | 34 +++++++++++++++++----------------- physics/samfdeepcnv.meta | 8 -------- physics/samfshalcnv.f | 9 ++++++--- 4 files changed, 29 insertions(+), 33 deletions(-) diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index 21612fd6c..c05af3003 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -26,8 +26,8 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! intent in integer, intent(in) :: im,km,kbcon1(im),ktcon(im) - real, intent(in) :: hvap,delt - real, intent(in) :: prevsq(im,km), q(im,km),del(im,km), & + real(kind=kind_phys), intent(in) :: hvap,delt + real(kind=kind_phys), intent(in) :: prevsq(im,km), q(im,km),del(im,km), & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & omega_u(im,km),zeta(im,km),gdx(im) logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow @@ -63,7 +63,8 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do i = 1,im sigmaout(i,k)=0. inbu(i,k)=0. - form(i,k)=0. + form(i,k)=0. + dp(i,k)=0. enddo enddo @@ -157,7 +158,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do k = 2,km1 do i = 1,im if(cnvflg(i))then - tem=(sigmab(i)*zeta(i,k)*inbu(i,k)*dbyo1(i,k))*dp(i,k) + tem=sigmab(i)*zeta(i,k)*inbu(i,k)*dbyo1(i,k)*dp(i,k) termA(i)=termA(i)+tem endif enddo @@ -167,7 +168,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do k = 2,km1 do i = 1,im if(cnvflg(i))then - tem=(dbyo1(i,k)*inbu(i,k))*dp(i,k) + tem=zeta(i,k)*dbyo1(i,k)*inbu(i,k)*dp(i,k) termB(i)=termB(i)+tem endif enddo diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index bf48d2035..071bf0557 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -86,8 +86,7 @@ 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, ca_micro, & - & errmsg,errflg) + & rainevap, sigmain, sigmaout, errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -108,7 +107,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & & tmf(:,:),q(:,:), prevsq(:,:) - real(kind=kind_phys), intent(out) :: rainevap(:), ca_micro(:) + 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 @@ -380,7 +379,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & advfac(i) = 0. rainevap(i) = 0. omegac(i)=0. - ca_micro(i)=0. gdx(i) = sqrt(garea(i)) enddo @@ -583,14 +581,20 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & buo(i,k) = 0. drag(i,k) = 0. cnvwt(i,k)= 0. + endif + enddo + enddo + + do k = 1, km + do i = 1, im dbyo1(i,k)=0. zdqca(i,k)=0. qlks(i,k)=0. omega_u(i,k)=0. zeta(i,k)=1.0 - endif - enddo + enddo enddo + ! ! initialize tracer variables ! @@ -1811,9 +1815,13 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & do i = 1, im if (cnvflg(i)) then if(k >= kbcon1(i) .and. k < ktcon(i)) then - zeta(i,k)=eta(i,k)*(omegac(i)/omega_u(i,k)) - zeta(i,k)=MAX(0.,zeta(i,k)) - zeta(i,k)=MIN(1.,zeta(i,k)) + if(omega_u(i,k) .ne. 0.)then + zeta(i,k)=eta(i,k)*(omegac(i)/omega_u(i,k)) + else + zeta(i,k)=0. + endif + zeta(i,k)=MAX(0.,zeta(i,k)) + zeta(i,k)=MIN(1.,zeta(i,k)) endif endif enddo @@ -2886,14 +2894,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. - if(progsigma)then - do i= 1, im - if(cnvflg(i))then - ca_micro(i)=sigmab(i) - endif - enddo - endif - do i= 1, im if(cnvflg(i) .and. .not.asqecflg(i)) then k = kbcon(i) diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 5e589b318..3f28035b6 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -660,14 +660,6 @@ type = real kind = kind_phys intent = out -[ca_micro] - standard_name = output_prognostic_sigma_two - long_name = output of prognostic area fraction two - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 325566877..ef0366b84 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -513,7 +513,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo enddo - do i = 1,im omegac(i)=0. enddo @@ -1551,12 +1550,16 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif enddo c -! > - Calculate the mean updraft velocity within the cloud (omega). +c Compute zeta for prog closure do k = 2, km1 do i = 1, im if (cnvflg(i)) then if(k > kbcon1(i) .and. k < ktcon(i)) then - zeta(i,k)=eta(i,k)*(omegac(i)/omega_u(i,k)) + if(omega_u(i,k) .ne. 0.)then + zeta(i,k)=eta(i,k)*(omegac(i)/omega_u(i,k)) + else + zeta(i,k)=0. + endif zeta(i,k)=MAX(0.,zeta(i,k)) zeta(i,k)=MIN(1.,zeta(i,k)) endif From 527e1b976bd74dc0214a13f91f804ec2334d862c Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 2 May 2022 22:11:42 +0000 Subject: [PATCH 190/217] Pass -DCCPP_SINGLE_PRECISION from cmake to -DSINGLE_PREC in cpp --- CMakeLists.txt | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 60531b9a5..691b283f2 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -29,6 +29,13 @@ if(CMAKE_BUILD_TYPE STREQUAL "Debug") add_definitions(-DDEBUG) endif() +if(CCPP_SINGLE_PREC) + message(STATUS "CCPP Single Precision Mode activated.") + add_definitions(SINGLE_PREC) +else(CCPP_SINGLE_PREC) + message(STATUS "CCPP Double Precision Mode activated.") +endif(CCPP_SINGLE_PREC) + #------------------------------------------------------------------------------ # Request a static build option(BUILD_SHARED_LIBS "Build a shared library" OFF) From 6871a936a9df8054fa2b4b34c6e52ad5d5cce738 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Wed, 4 May 2022 17:32:24 +0000 Subject: [PATCH 191/217] Changes needed for 32-bit physics --- CMakeLists.txt | 7 ---- physics/GFS_rrtmgp_cloud_overlap.F90 | 4 +-- physics/GFS_suite_interstitial_4.F90 | 10 +++--- physics/calpreciptype.f90 | 9 ++++- physics/machine.F | 2 +- physics/maximum_hourly_diagnostics.F90 | 14 ++++---- physics/mersenne_twister.f | 46 ++++++++++++++------------ physics/module_sf_mynn.F90 | 4 +-- physics/module_sf_noahmplsm.f90 | 4 +-- physics/module_sf_ruclsm.F90 | 5 +-- physics/module_soil_pre.F90 | 24 ++++++++------ physics/radiation_gases.f | 2 +- physics/radlw_main.meta | 2 +- physics/radsw_main.F90 | 2 +- physics/radsw_main.meta | 2 +- 15 files changed, 72 insertions(+), 65 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 691b283f2..60531b9a5 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -29,13 +29,6 @@ if(CMAKE_BUILD_TYPE STREQUAL "Debug") add_definitions(-DDEBUG) endif() -if(CCPP_SINGLE_PREC) - message(STATUS "CCPP Single Precision Mode activated.") - add_definitions(SINGLE_PREC) -else(CCPP_SINGLE_PREC) - message(STATUS "CCPP Double Precision Mode activated.") -endif(CCPP_SINGLE_PREC) - #------------------------------------------------------------------------------ # Request a static build option(BUILD_SHARED_LIBS "Build a shared library" OFF) diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 index 13794641b..c1a6c4763 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -99,7 +99,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! Cloud overlap parameter ! if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then - call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001, de_lgth, cld_frac, cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001_kind_phys, de_lgth, cld_frac, cloud_overlap_param) else de_lgth(:) = 0. cloud_overlap_param(:,:) = 0. @@ -110,7 +110,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then if (iovr_convcld == iovr_dcorr .or. iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then - call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001_kind_phys, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) else de_lgth(:) = 0. cnv_cloud_overlap_param(:,:) = 0. diff --git a/physics/GFS_suite_interstitial_4.F90 b/physics/GFS_suite_interstitial_4.F90 index cbabb991b..18fcfda09 100644 --- a/physics/GFS_suite_interstitial_4.F90 +++ b/physics/GFS_suite_interstitial_4.F90 @@ -224,7 +224,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) / (one-spechum(i,k)) !> - Convert number concentration from moist to dry nc_mp(i,k) = gq0(i,k,ntlnc) / (one-spechum(i,k)) - nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(real(qc_mp(i,k) * rho), real(nwfa(i,k)*rho)) * orho) !> - Convert number concentrations from dry to moist gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) endif @@ -233,7 +233,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) / (one-spechum(i,k)) !> - Convert number concentration from moist to dry ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) - ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(real(qi_mp(i,k) * rho), real(save_tcp(i,k)) * orho)) !> - Convert number concentrations from dry to moist gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) endif @@ -249,13 +249,13 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr !> - Update cloud water mixing ratio qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) !> - Update cloud water number concentration - gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(real(qc_mp(i,k) * rho), real(nwfa(i,k)*rho)) * orho) endif if (ntinc>0) then !> - Update cloud ice mixing ratio qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) !> - Update cloud ice number concentration - gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(real(qi_mp(i,k) * rho), real(save_tcp(i,k))) * orho) endif enddo enddo @@ -290,4 +290,4 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr end subroutine GFS_suite_interstitial_4_run - end module GFS_suite_interstitial_4 \ No newline at end of file + end module GFS_suite_interstitial_4 diff --git a/physics/calpreciptype.f90 b/physics/calpreciptype.f90 index d3fbb253b..956ed8c55 100644 --- a/physics/calpreciptype.f90 +++ b/physics/calpreciptype.f90 @@ -509,7 +509,14 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) real(kind=kind_phys) rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & rhavg,dtavg,dpk,ptw,pbot ! real(kind=kind_phys) b,qtmp,rate,qc -! real(kind=kind_phys),external :: xmytw (now inside the module) +! + interface + function xmytw(t,td,p) + use machine , only : kind_phys + implicit none + real(kind=kind_phys) t, td, p, xmytw + end function xmytw + end interface ! ! initialize. icefrac = -9999. diff --git a/physics/machine.F b/physics/machine.F index 2ee7fb865..9b09d235c 100644 --- a/physics/machine.F +++ b/physics/machine.F @@ -33,7 +33,7 @@ module machine # endif &, kind_rad = 4 & &, kind_phys = 4 ,kind_taum=4 & - &, kind_grid = 4 & + &, kind_grid = 8 &! atmos_cubed_sphere requres kind_grid=8 &, kind_REAL = 4 &! used in cmp_comm &, kind_LOGICAL = 4 & &, kind_INTEGER = 4 ! -,,- diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 6beae0da2..ddbff5725 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -144,11 +144,11 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) real (kind=kind_phys), intent(in) :: grav real (kind=kind_phys), intent(in),dimension(:,:) :: phil,ref3D,tk integer :: i,k,ll,ipt,kpt - real :: dbz1avg,zmidp1,zmidloc,refl,fact - real, dimension(im,levs) :: z - real, dimension(im) :: zintsfc - real, dimension(:), intent(inout) :: refd,refd263k - REAL :: dbz1(2),dbzk,dbzk1 + real(kind_phys) :: dbz1avg,zmidp1,zmidloc,refl,fact + real(kind_phys), dimension(im,levs) :: z + real(kind_phys), dimension(im) :: zintsfc + real(kind_phys), dimension(:), intent(inout) :: refd,refd263k + REAL(kind_phys) :: dbz1(2),dbzk,dbzk1 logical :: counter do i=1,im do k=1,levs @@ -185,7 +185,7 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) dbz1avg=dbz1(2)+(dbz1(2)-dbz1(1))*fact !-- Convert to dBZ (10*logZ) as the last step if (dbz1avg>0.01) then - dbz1avg=10.*alog10(dbz1avg) + dbz1avg=10.*log10(dbz1avg) else dbz1avg=-35. endif @@ -214,7 +214,7 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) dbz1avg=maxval(dbz1) !-- Convert to dBZ (10*logZ) as the last step if (dbz1avg>0.01) then - dbz1avg=10.*alog10(dbz1avg) + dbz1avg=10.*log10(dbz1avg) else dbz1avg=-35. endif diff --git a/physics/mersenne_twister.f b/physics/mersenne_twister.f index 8cc6bd5e5..58bf43487 100644 --- a/physics/mersenne_twister.f +++ b/physics/mersenne_twister.f @@ -160,6 +160,7 @@ ! !$$$ module mersenne_twister + use machine, only: kind_dbl_prec private ! Public declarations public random_stat @@ -188,7 +189,7 @@ module mersenne_twister integer:: mti=n+1 integer:: mt(0:n-1) integer:: iset - real:: gset + real(kind_dbl_prec):: gset end type ! Saved data type(random_stat),save:: sstat @@ -300,8 +301,8 @@ subroutine random_setseed_t(inseed,stat) !> This function generates random numbers in functional mode. function random_number_f() result(harvest) implicit none - real:: harvest - real h(1) + real(kind_dbl_prec):: harvest + real(kind_dbl_prec) :: h(1) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_number_t(h,sstat) harvest=h(1) @@ -310,7 +311,7 @@ function random_number_f() result(harvest) !> This subroutine generates random numbers in interactive mode. subroutine random_number_i(harvest,inseed) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) integer,intent(in):: inseed type(random_stat) stat call random_setseed_t(inseed,stat) @@ -320,7 +321,7 @@ subroutine random_number_i(harvest,inseed) !> This subroutine generates random numbers in saved mode; overloads Fortran 90 standard. subroutine random_number_s(harvest) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_number_t(harvest,sstat) end subroutine @@ -328,7 +329,7 @@ subroutine random_number_s(harvest) !> This subroutine generates random numbers in thread-safe mode. subroutine random_number_t(harvest,stat) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) type(random_stat),intent(inout):: stat integer j,kk,y integer tshftu,tshfts,tshftt,tshftl @@ -359,9 +360,12 @@ subroutine random_number_t(harvest,stat) y=ieor(y,iand(tshftt(y),tmaskc)) y=ieor(y,tshftl(y)) if(y.lt.0) then - harvest(j)=(real(y)+2.0**32)/(2.0**32-1.0) + harvest(j)=(real(y,kind=kind_dbl_prec)+ & + & 2.0_kind_dbl_prec**32)/ & + & (2.0_kind_dbl_prec**32-1.0_kind_dbl_prec) else - harvest(j)=real(y)/(2.0**32-1.0) + harvest(j)=real(y)/(2.0_kind_dbl_prec**32- & + & 1.0_kind_dbl_prec) endif stat%mti=stat%mti+1 enddo @@ -370,8 +374,8 @@ subroutine random_number_t(harvest,stat) !> This subrouitne generates Gaussian random numbers in functional mode. function random_gauss_f() result(harvest) implicit none - real:: harvest - real h(1) + real(kind_dbl_prec):: harvest + real(kind_dbl_prec) :: h(1) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_gauss_t(h,sstat) harvest=h(1) @@ -380,7 +384,7 @@ function random_gauss_f() result(harvest) !> This subrouitne generates Gaussian random numbers in interactive mode. subroutine random_gauss_i(harvest,inseed) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) integer,intent(in):: inseed type(random_stat) stat call random_setseed_t(inseed,stat) @@ -390,7 +394,7 @@ subroutine random_gauss_i(harvest,inseed) !> This subroutine generates Gaussian random numbers in saved mode. subroutine random_gauss_s(harvest) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_gauss_t(harvest,sstat) end subroutine @@ -398,10 +402,10 @@ subroutine random_gauss_s(harvest) !> This subroutine generates Gaussian random numbers in thread-safe mode. subroutine random_gauss_t(harvest,stat) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) type(random_stat),intent(inout):: stat integer mx,my,mz,j - real r2(2),r,g1,g2 + real(kind_dbl_prec) :: r2(2),r,g1,g2 mz=size(harvest) if(mz.le.0) return mx=0 @@ -436,14 +440,14 @@ subroutine random_gauss_t(harvest,stat) contains !> This subroutine contains numerical Recipes algorithm to generate Gaussian random numbers. subroutine rgauss(r1,r2,r,g1,g2) - real,intent(in):: r1,r2 - real,intent(out):: r,g1,g2 - real v1,v2,fac - v1=2.*r1-1. - v2=2.*r2-1. + real(kind_dbl_prec),intent(in):: r1,r2 + real(kind_dbl_prec),intent(out):: r,g1,g2 + real(kind_dbl_prec) :: v1,v2,fac + v1=2._kind_dbl_prec*r1-1._kind_dbl_prec + v2=2._kind_dbl_prec*r2-1._kind_dbl_prec r=v1**2+v2**2 if(r.lt.1.) then - fac=sqrt(-2.*log(r)/r) + fac=sqrt(-2._kind_dbl_prec*log(r)/r) g1=v1*fac g2=v2*fac endif @@ -489,7 +493,7 @@ subroutine random_index_t(imax,iharvest,stat) type(random_stat),intent(inout):: stat integer,parameter:: mh=n integer i1,i2,mz - real h(mh) + real(kind_dbl_prec) :: h(mh) mz=size(iharvest) do i1=1,mz,mh i2=min((i1-1)+mh,mz) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 5f227750a..bc874ace6 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -2804,8 +2804,8 @@ SUBROUTINE znot_m_v6(uref, znotm) ! znotm(meter): areodynamical roughness scale over water ! - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znotm + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znotm real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02,& & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00,& & p10 = -8.396975715683501e+00, & diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 1c899e4bd..61b92990b 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -681,7 +681,7 @@ subroutine noahmp_sflx (parameters, & logical :: dveg_active !< flag to run dynamic vegetation logical :: crop_active !< flag to run crop model ! add canopy heat storage (C.He added based on GY Niu's communication) - real :: canhs ! canopy heat storage change w/m2 + real (kind=kind_phys) :: canhs ! canopy heat storage change w/m2 ! maximum lai/sai used for some parameterizations based on plant growthi @@ -4494,7 +4494,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0_kind_phys,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index b39610bc8..a27d0f287 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -7603,10 +7603,11 @@ END SUBROUTINE SOILIN !>\ingroup lsm_ruc_group !> This function calculates the liquid saturation vapor mixing ratio as !! a function of temperature and pressure (from Thompson scheme). - REAL FUNCTION RSLF(P,T) + FUNCTION RSLF(P,T) IMPLICIT NONE - REAL, INTENT(IN):: P, T + REAL(kind_phys), INTENT(IN):: P, T + REAL(kind_phys) :: RSLF REAL:: ESL,X REAL, PARAMETER:: C0= .611583699E03 REAL, PARAMETER:: C1= .444606896E02 diff --git a/physics/module_soil_pre.F90 b/physics/module_soil_pre.F90 index 8eb5a5775..149f87a1c 100644 --- a/physics/module_soil_pre.F90 +++ b/physics/module_soil_pre.F90 @@ -5,6 +5,8 @@ module module_soil_pre !tgs Initialize RUC LSM levels, soil temp/moisture + use machine, only: kind_phys + implicit none private @@ -26,8 +28,8 @@ SUBROUTINE init_soil_depth_3 ( zs , dzs , num_soil_levels ) INTEGER, INTENT(IN) :: num_soil_levels - REAL, DIMENSION(1:num_soil_levels), INTENT(OUT) :: zs, dzs - REAL, DIMENSION(1:num_soil_levels) :: zs2 + REAL(kind_phys), DIMENSION(1:num_soil_levels), INTENT(OUT) :: zs, dzs + REAL(kind_phys), DIMENSION(1:num_soil_levels) :: zs2 INTEGER :: l @@ -90,21 +92,21 @@ SUBROUTINE init_soil_3_real ( tsk , tmn , smois , tslb , & INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input - REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input - REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input - REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + REAL(kind_phys) , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input + REAL(kind_phys) , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input + REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst - REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn - REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk - REAL , DIMENSION(num_soil_layers) :: zs , dzs + REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn + REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk + REAL(kind_phys) , DIMENSION(num_soil_layers) :: zs , dzs - REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois + REAL(kind_phys) , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois - REAL , ALLOCATABLE , DIMENSION(:) :: zhave + REAL(kind_phys) , ALLOCATABLE , DIMENSION(:) :: zhave logical :: debug_print = .false. INTEGER :: i , j , l , lout , lin , lwant , lhave, k - REAL :: temp + REAL(kind_phys) :: temp ! Allocate the soil layer array used for interpolating. diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f index 157da8e09..d6f1d7259 100644 --- a/physics/radiation_gases.f +++ b/physics/radiation_gases.f @@ -371,7 +371,7 @@ subroutine gas_init & endif do k = 1, LOZ - pkstr(k) = fpkapx(pstr(k)*100.0) + pkstr(k) = fpkapx(pstr(k)*100.0_kind_phys) enddo endif ! end if_ioznflg_block diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index df1a368c5..9286c45cb 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw type = scheme - dependencies = mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f + dependencies = machine.F,mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index ae2fa7ad5..5d7d62dcc 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -2040,7 +2040,7 @@ subroutine mcica_subcol & real (kind=kind_phys) :: cdfunc(nlay,ngptsw), tem1, & & fac_lcf(nlay), & & cdfun2(nlay,ngptsw) - real (kind=kind_dbl_prec) :: rand2d(nlay*ngptsw), rand1d(ngptsw) + real (kind=kind_dbl_prec) :: rand2d(nlay*ngptsw), rand1d(ngptsw) ! must be default real kind to match mersenne twister code type (random_stat) :: stat ! for thread safe random generator diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index 70bc136f3..506e2edf0 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw type = scheme - dependencies = mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f + dependencies = machine.F,mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f ######################################################################## [ccpp-arg-table] From 5c6243d5c47dd12e392e9afa9f954a771625cd51 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Wed, 4 May 2022 19:57:04 +0000 Subject: [PATCH 192/217] adding bug fix from jili dong and removing U* averaging --- physics/module_sf_mynn.F90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 31335d3a9..f82597b15 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -848,8 +848,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & DO I=its,ite ! CONVERT LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: - TH1D(I)=T1D(I)*THCON(I) !(Theta, K) - TC1D(I)=T1D(I)-273.15 !(T, Celsius) + TH1D(I)=T1D(I)**(100000./P1D(I))**ROVCP !(Theta, K) + TC1D(I)=T1D(I)-273.15 !(T, Celsius) ENDDO DO I=its,ite @@ -859,7 +859,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDDO DO I=its,ite - RHO1D(I)=PSFCPA(I)/(R*TV1D(I)) !now using value calculated in sfc driver + RHO1D(I)=P1D(I)/(R*TV1D(I)) !now using value calculated in sfc driver ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level ZA2(I)=dz8w1d(I) + 0.5*dz2w1d(I) !height of 2nd half-sigma level GOVRTH(I)=G/TH1D(I) @@ -1724,9 +1724,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (wet(I)) THEN ! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE OLDUST = UST_wat(I) - UST_wat(I)=0.5*UST_wat(I)+0.5*KARMAN*WSPD(I)/PSIX_wat(I) + !UST_wat(I)=0.5*UST_wat(I)+0.5*KARMAN*WSPD(I)/PSIX_wat(I) !NON-AVERAGED: - !UST_wat(I)=KARMAN*WSPD(I)/PSIX_wat(I) + UST_wat(I)=KARMAN*WSPD(I)/PSIX_wat(I) stress_wat(i)=ust_wat(i)**2 ! Compute u* without vconv for use in HFX calc when isftcflx > 0 @@ -1891,7 +1891,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !---------------------------------- ! COMPUTE SURFACE HEAT FLUX: !---------------------------------- - HFX(I)=FLHC(I)*(THSK_lnd(I)-TH1D(I)) + !HFX(I)=FLHC(I)*(THSK_lnd(I)-TH1D(I)) + HFX(I)=RHO1D(I)*CPM(I)*KARMAN*WSPD(i)/PSIX_lnd(I)*KARMAN/PSIT_lnd(I)*(THSK_lnd(I)-TH1D(i)) HFX(I)=MAX(HFX(I),-250.) ! BWG, 2020-06-17: Mod next 2 lines for fractional HFLX_lnd(I)=HFX(I)/(RHO1D(I)*cpm(I)) @@ -1935,7 +1936,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !---------------------------------- ! COMPUTE SURFACE HEAT FLUX: !---------------------------------- - HFX(I)=FLHC(I)*(THSK_wat(I)-TH1D(I)) + !HFX(I)=FLHC(I)*(THSK_wat(I)-TH1D(I)) + HFX(I)=RHO1D(I)*CPM(I)*KARMAN*WSPD(i)/PSIX_wat(I)*KARMAN/PSIT_wat(I)*(THSK_wat(I)-TH1D(i)) IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX.NE.0 ) THEN ! AHW: add dissipative heating term @@ -1982,7 +1984,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !---------------------------------- ! COMPUTE SURFACE HEAT FLUX: !---------------------------------- - HFX(I)=FLHC(I)*(THSK_ice(I)-TH1D(I)) + !HFX(I)=FLHC(I)*(THSK_ice(I)-TH1D(I)) + HFX(I)=RHO1D(I)*CPM(I)*KARMAN*WSPD(i)/PSIX_ice(I)*KARMAN/PSIT_ice(I)*(THSK_ice(I)-TH1D(i)) HFX(I)=MAX(HFX(I),-250.) ! BWG, 2020-06-17: Mod next 2 lines for fractional HFLX_ice(I)=HFX(I)/(RHO1D(I)*cpm(I)) From e7c42c7d57740d6f8c3852ce3d9dfbab720e6c86 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 5 May 2022 00:43:21 +0000 Subject: [PATCH 193/217] Move some code to modules --- physics/GFS_MP_generic_post.F90 | 2 +- physics/calpreciptype.f90 | 10 +++------- physics/cires_orowam2017.f | 3 +++ physics/cires_ugwp.F90 | 5 +++++ physics/cires_ugwp_triggers.F90 | 3 +++ physics/cires_ugwpv1_oro.F90 | 2 +- physics/cires_ugwpv1_sporo.F90 | 4 +++- physics/hedmf.f | 3 ++- physics/lsm_noah.f | 1 + physics/mfpbl.f | 4 +++- physics/mfpblt.f | 4 +++- physics/mfpbltq.f | 4 +++- physics/mfscu.f | 4 +++- physics/mfscuq.f | 4 +++- physics/module_bl_mynn.F90 | 3 +++ physics/moninshoc.f | 3 +++ physics/satmedmfvdif.F | 4 ++++ physics/satmedmfvdifq.F | 4 +++- physics/sflx.f | 12 +++++++++++- physics/tridi.f | 4 +++- physics/ugwp_driver_v0.F | 5 ++++- physics/unified_ugwp.F90 | 3 ++- 22 files changed, 70 insertions(+), 21 deletions(-) diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90 index a7be0ab4c..97deec10f 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -30,7 +30,7 @@ subroutine GFS_MP_generic_post_run( index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, errmsg, errflg) ! use machine, only: kind_phys - + use calpreciptype_mod, only: calpreciptype implicit none integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac, num_dfi_radar, index_of_process_dfi_radar diff --git a/physics/calpreciptype.f90 b/physics/calpreciptype.f90 index 956ed8c55..54e8fa2b9 100644 --- a/physics/calpreciptype.f90 +++ b/physics/calpreciptype.f90 @@ -1,6 +1,8 @@ !>\file calpreciptype.f90 !! This file contains the subroutines that calculates dominant precipitation type. +module calpreciptype_mod +contains !>\ingroup gfs_calpreciptype !! Foure algorithms are called to calculate dominant precipitation type, and the !!tallies are sumed in calwxt_dominant(). @@ -510,13 +512,6 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) rhavg,dtavg,dpk,ptw,pbot ! real(kind=kind_phys) b,qtmp,rate,qc ! - interface - function xmytw(t,td,p) - use machine , only : kind_phys - implicit none - real(kind=kind_phys) t, td, p, xmytw - end function xmytw - end interface ! ! initialize. icefrac = -9999. @@ -1391,3 +1386,4 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & return end !! @} +end module calpreciptype_mod diff --git a/physics/cires_orowam2017.f b/physics/cires_orowam2017.f index c20f98f42..ae5f355d3 100644 --- a/physics/cires_orowam2017.f +++ b/physics/cires_orowam2017.f @@ -1,3 +1,5 @@ + module cires_orowam2017 + contains subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & del, sigma, hprime, gamma, theta, @@ -384,3 +386,4 @@ subroutine ugwpv0_tofd1d(levs, sigflt, elvmax, zsurf, enddo ! end subroutine ugwpv0_tofd1d + end module cires_orowam2017 diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index c4f0a255d..2d8eafc19 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -16,9 +16,14 @@ module cires_ugwp use machine, only: kind_phys use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize + use ugwp_driver_v0 use gwdps, only: gwdps_run + use cires_ugwp_triggers + + use ugwp_driver_v0 + implicit none private diff --git a/physics/cires_ugwp_triggers.F90 b/physics/cires_ugwp_triggers.F90 index 4a8b97590..82f762c56 100644 --- a/physics/cires_ugwp_triggers.F90 +++ b/physics/cires_ugwp_triggers.F90 @@ -1,3 +1,5 @@ + module cires_ugwp_triggers + contains ! subroutine slat_geos5_tamp_v0(im, tau_amp, xlatdeg, tau_gw) !================= @@ -97,3 +99,4 @@ subroutine init_nazdir_v0(naz, xaz, yaz) yaz(4) =-1.0 !S endif end subroutine init_nazdir_v0 + end module cires_ugwp_triggers diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 index 247112bf1..66d0e472c 100644 --- a/physics/cires_ugwpv1_oro.F90 +++ b/physics/cires_ugwpv1_oro.F90 @@ -1,5 +1,5 @@ module cires_ugwpv1_oro - + use cires_ugwpv1_sporo contains subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & diff --git a/physics/cires_ugwpv1_sporo.F90 b/physics/cires_ugwpv1_sporo.F90 index c840b49d8..fbd3eaa0b 100644 --- a/physics/cires_ugwpv1_sporo.F90 +++ b/physics/cires_ugwpv1_sporo.F90 @@ -1,4 +1,5 @@ - + module cires_ugwpv1_sporo + contains subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & del, sigma, hprime, gamma, theta, & @@ -349,3 +350,4 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & end subroutine oro_meanflow + end module cires_ugwpv1_sporo diff --git a/physics/hedmf.f b/physics/hedmf.f index 83d0fe1b0..604483e53 100644 --- a/physics/hedmf.f +++ b/physics/hedmf.f @@ -5,7 +5,8 @@ !> This module contains the CCPP-compliant hybrid eddy-diffusivity mass-flux !! scheme. module hedmf - + use tridi_mod + use mfpbl_mod contains !> \section arg_table_hedmf_init Argument Table diff --git a/physics/lsm_noah.f b/physics/lsm_noah.f index d519dcda5..7a8e17bf8 100644 --- a/physics/lsm_noah.f +++ b/physics/lsm_noah.f @@ -7,6 +7,7 @@ module lsm_noah use machine, only: kind_phys use set_soilveg_mod, only: set_soilveg use namelist_soilveg + use sflx implicit none diff --git a/physics/mfpbl.f b/physics/mfpbl.f index 2df84945b..dac548711 100644 --- a/physics/mfpbl.f +++ b/physics/mfpbl.f @@ -1,6 +1,7 @@ !> \file mfpbl.f !! This file contains the subroutine that calculates the updraft properties and mass flux for use in the Hybrid EDMF PBL scheme. - + module mfpbl_mod + contains !> \ingroup HEDMF !! \brief This subroutine is used for calculating the mass flux and updraft properties. !! @@ -396,3 +397,4 @@ subroutine mfpbl(im,ix,km,ntrac,delt,cnvflg, & return end !> @} + end module mfpbl_mod diff --git a/physics/mfpblt.f b/physics/mfpblt.f index bd0baf558..67e554b92 100644 --- a/physics/mfpblt.f +++ b/physics/mfpblt.f @@ -2,7 +2,8 @@ !! This file contains the subroutine that calculates mass flux and !! updraft parcel properties for thermals driven by surface heating !! for use in the TKE-EDMF PBL scheme. - + module mfpblt_mod + contains !>\ingroup satmedmf !! This subroutine computes mass flux and updraft parcel properties for !! thermals driven by surface heating. @@ -452,3 +453,4 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & return end !> @} + end module mfpblt_mod diff --git a/physics/mfpbltq.f b/physics/mfpbltq.f index c4333290b..4555af268 100644 --- a/physics/mfpbltq.f +++ b/physics/mfpbltq.f @@ -2,7 +2,8 @@ !! This file contains the subroutine that calculates mass flux and !! updraft parcel properties for thermals driven by surface heating !! for use in the TKE-EDMF PBL scheme (updated version). - + module mfpbltq_mod + contains !>\ingroup satmedmfvdifq !! This subroutine computes mass flux and updraft parcel properties for !! thermals driven by surface heating. @@ -477,3 +478,4 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, return end !> @} + end module mfpbltq_mod diff --git a/physics/mfscu.f b/physics/mfscu.f index 9128c7c10..e0c184139 100644 --- a/physics/mfscu.f +++ b/physics/mfscu.f @@ -1,7 +1,8 @@ !>\file mfscu.f !! This file contains the mass flux and downdraft parcel preperties !! parameterization for stratocumulus-top-driven turbulence. - + module mfscu_mod + contains !>\ingroup satmedmf !! This subroutine computes mass flux and downdraft parcel properties !! for stratocumulus-top-driven turbulence. @@ -554,3 +555,4 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & return end !> @} + end module mfscu_mod diff --git a/physics/mfscuq.f b/physics/mfscuq.f index 3c54b0bda..ca4819956 100644 --- a/physics/mfscuq.f +++ b/physics/mfscuq.f @@ -1,7 +1,8 @@ !>\file mfscuq.f !! This file contains the mass flux and downdraft parcel preperties !! parameterization for stratocumulus-top-driven turbulence (updated version). - + module mfscuq_mod + contains !>\ingroup satmedmfvdifq !! This subroutine computes mass flux and downdraft parcel properties !! for stratocumulus-top-driven turbulence. @@ -557,3 +558,4 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, return end !> @} + end module mfscuq_mod diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 7b98b1c93..334d1db4c 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -1384,8 +1384,11 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos lb1 = min(dlu,dld) !minimum !JOE-fight floating point errors +#ifdef SINGLE_PREC + !JM: keep up the fight, JOE dlu=MAX(0.1,MIN(dlu,1000.)) dld=MAX(0.1,MIN(dld,1000.)) +#endif lb2 = sqrt(dlu*dld) !average - biased towards smallest !lb2 = 0.5*(dlu+dld) !average diff --git a/physics/moninshoc.f b/physics/moninshoc.f index 4e9e60b46..ee4715e81 100644 --- a/physics/moninshoc.f +++ b/physics/moninshoc.f @@ -4,6 +4,9 @@ !> This module contains the CCPP-compliant SHOC scheme. module moninshoc + use mfpbl_mod + use tridi_mod + contains subroutine moninshoc_init (do_shoc, errmsg, errflg) diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index feb4ef870..f791a2de4 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -5,6 +5,10 @@ module satmedmfvdif + use tridi_mod + use mfscu_mod + use mfpblt_mod + contains !> \section arg_table_satmedmfvdif_init Argument Table diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index eb2b7ad1c..9c5ad4029 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -4,7 +4,9 @@ !! eddy-diffusion mass-flux (TKE-EDMF) parameterization (by Jongil Han). module satmedmfvdifq - + use mfpbltq_mod + use tridi_mod + use mfscuq_mod contains !> \defgroup satmedmfvdifq GFS Scale-aware TKE-based Moist Eddy-Diffusivity Mass-flux (TKE-EDMF, updated version) Scheme Module diff --git a/physics/sflx.f b/physics/sflx.f index 61fe015cc..026e2b854 100644 --- a/physics/sflx.f +++ b/physics/sflx.f @@ -1,6 +1,7 @@ !>\file sflx.f !! This file is the entity of GFS Noah LSM Model(Version 2.7). - + module sflx + contains !>\ingroup Noah_LSM !!\brief This is the entity of GFS Noah LSM model of physics subroutines. !! It is a soil/veg/snowpack land-surface model to update soil moisture, soil @@ -906,7 +907,15 @@ subroutine gfssflx &! --- input eta = etp endif +#ifdef SINGLE_PREC + IF (ETP == 0.0) THEN + BETA = 0.0 + ELSE + BETA = ETA/ETP + ENDIF +#else beta = eta / etp +#endif !> - Convert the sign of soil heat flux so that: !! - ssoil>0: warm the surface (night time) @@ -5801,3 +5810,4 @@ end subroutine wdfcnd end subroutine gfssflx !! @} !----------------------------------- + end module sflx diff --git a/physics/tridi.f b/physics/tridi.f index 0103b388f..13202512f 100644 --- a/physics/tridi.f +++ b/physics/tridi.f @@ -1,6 +1,7 @@ !>\file tridi.f !! These subroutines are originally internal subroutines in moninedmf.f - + module tridi_mod + contains !>\ingroup HEDMF !!\brief Routine to solve the tridiagonal system to calculate !!temperature and moisture at \f$ t + \Delta t \f$; part of two-part @@ -220,3 +221,4 @@ subroutine tridit(l,n,nt,cl,cm,cu,rt,au,at) return end subroutine tridit !> @} + end module tridi_mod diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index 844acf722..cd19f5f71 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -1,5 +1,7 @@ !>\file ugwp_driver_v0.F - + module ugwp_driver_v0 + use cires_orowam2017 + contains ! !===================================================================== ! @@ -1485,3 +1487,4 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, end subroutine fv3_ugwp_solv2_v0 + end module ugwp_driver_v0 diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 9e93bd5fc..0b45d680d 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -37,7 +37,8 @@ module unified_ugwp ! use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize use gwdps, only: gwdps_run - + use cires_ugwp_triggers + use ugwp_driver_v0 use drag_suite, only: drag_suite_run implicit none From be534e7be9c335c9d8736fe0d5bf8fe83e14cce9 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Thu, 5 May 2022 04:08:06 +0000 Subject: [PATCH 194/217] addressing some review comments --- physics/progsigma_calc.f90 | 114 +++++++++++++++++++------------------ physics/samfdeepcnv.f | 16 +++++- physics/samfdeepcnv.meta | 8 +++ 3 files changed, 80 insertions(+), 58 deletions(-) diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index c05af3003..fe74dc0c1 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -48,7 +48,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, & fdqb,dtdyn,dxlim,rmulacvg,tem, & - alpha,DEN,betascu,dp1 + alpha,DEN,betascu,dp1,invdelt !Parameters gcvalmx = 0.1 @@ -57,11 +57,11 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & km1=km-1 alpha=7000. betascu = 3.0 + invdelt = 1./delt !Initialization 2D do k = 1,km do i = 1,im - sigmaout(i,k)=0. inbu(i,k)=0. form(i,k)=0. dp(i,k)=0. @@ -70,7 +70,9 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & !Initialization 1D do i=1,im - sigmab(i)=0. + if(cnvflg(i))then + sigmab(i)=0. + endif sigmamax(i)=0.95 termA(i)=0. termB(i)=0. @@ -89,24 +91,16 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & enddo !Initial computations, place maximum sigmain in sigmab - if(flag_init .and. .not. flag_restart)then - do i=1,im - if(cnvflg(i))then - sigmab(i)=0.03 - endif - enddo - else - do i=1,im - if(cnvflg(i))then - do k=2,km - if(sigmain(i,k)>sigmab(i))then - sigmab(i)=sigmain(i,k) - endif - enddo - endif - enddo - endif - + do i=1,im + if(cnvflg(i))then + do k=2,km + if(sigmain(i,k)>sigmab(i))then + sigmab(i)=sigmain(i,k) + endif + enddo + endif + enddo + do i=1,im if(sigmab(i) < 1.E-5)then !after advection sigmab(i)=0. @@ -120,15 +114,20 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & enddo !Initial computations, dynamic q-tendency - do k = 1,km - do i = 1,im - if(flag_init .and. .not.flag_restart)then + if(flag_init .and. .not.flag_restart)then + do k = 1,km + do i = 1,im qadv(i,k)=0. - else - qadv(i,k)=(q(i,k) - prevsq(i,k))/delt - endif + enddo enddo - enddo + else + do k = 1,km + do i = 1,im + qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt + enddo + enddo + endif + !compute termD "The vertical integral of the latent heat convergence is limited to the !buoyant layers with positive moisture convergence (accumulated from the surface). @@ -173,7 +172,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & endif enddo enddo - + !termC do k = 2,km1 do i = 1,im @@ -188,33 +187,38 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & enddo !sigmab - do i = 1,im - if(cnvflg(i))then - DEN=MIN(termC(i)+termB(i),1.E8) - cvg=termD(i)*delt - ZZ=MAX(0.0,SIGN(1.0,termA(i))) & - *MAX(0.0,SIGN(1.0,termB(i))) & - *MAX(0.0,SIGN(1.0,termC(i)-epsilon)) - cvg=MAX(0.0,cvg) - if(flag_init .and. .not. flag_restart)then - sigmab(i)=0.03 - else - sigmab(i)=(ZZ*(termA(i)+cvg))/(DEN+(1.0-ZZ)) - endif - if(sigmab(i)>0.)then - sigmab(i)=MIN(sigmab(i),sigmamax(i)) - sigmab(i)=MAX(sigmab(i),0.01) - endif - endif!cnvflg - enddo + if(flag_init .and. .not. flag_restart)then + do i = 1,im + if(cnvflg(i))then + sigmab(i)=0.03 + endif + enddo + else + do i = 1,im + if(cnvflg(i))then + DEN=MIN(termC(i)+termB(i),1.E8) + cvg=termD(i)*delt + ZZ=MAX(0.0,SIGN(1.0,termA(i))) & + *MAX(0.0,SIGN(1.0,termB(i))) & + *MAX(0.0,SIGN(1.0,termC(i)-epsilon)) + cvg=MAX(0.0,cvg) + sigmab(i)=(ZZ*(termA(i)+cvg))/(DEN+(1.0-ZZ)) + if(sigmab(i)>0.)then + sigmab(i)=MIN(sigmab(i),sigmamax(i)) + sigmab(i)=MAX(sigmab(i),0.01) + endif + endif!cnvflg + enddo + endif - do k=1,km - do i=1,im - if(cnvflg(i))then - sigmaout(i,k)=sigmab(i) - endif - enddo - enddo + do k=1,km + do i=1,im + if(cnvflg(i))then + sigmaout(i,k)=sigmab(i) + endif + enddo + enddo + !Since updraft velocity is much lower in shallow cu region, termC becomes small in shallow cu application, thus the area fraction !in this regime becomes too large compared with the deep cu region. To address this simply apply a scaling factor for shallow cu diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 071bf0557..8398af769 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -85,8 +85,8 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & QLCN, QICN, w_upi, cf_upi, CNV_MFD, & & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys,mp_phys_mg,& & clam,c0s,c1,betal,betas,evef,pgcon,asolfac, & - & do_ca, ca_closure, ca_entr, ca_trigger, nthresh, ca_deep, & - & rainevap, sigmain, sigmaout, errmsg,errflg) + & do_ca, ca_closure, ca_entr, ca_trigger, nthresh,ca_deep, & + & ca_micro, rainevap, sigmain, sigmaout, errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -107,7 +107,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & & tmf(:,:),q(:,:), prevsq(:,:) - real(kind=kind_phys), intent(out) :: rainevap(:) + real(kind=kind_phys), intent(out) :: rainevap(:), ca_micro(:) real(kind=kind_phys), intent(out) :: sigmaout(:,:) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger @@ -2894,6 +2894,16 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. + do i=1,im + ca_micro(i)=0. + enddo + + do i=1,im + if(cnvflg(i))then + ca_micro(i)=sigmab(i) + endif + enddo + do i= 1, im if(cnvflg(i) .and. .not.asqecflg(i)) then k = kbcon(i) diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 3f28035b6..1764a74fd 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -652,6 +652,14 @@ type = real kind = kind_phys intent = in +[ca_micro] + standard_name = output_prognostic_sigma_two + long_name = output of prognostic area fraction two + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [rainevap] standard_name = physics_field_for_coupling long_name = physics_field_for_coupling From bb45b2b08f87c2737937e7a3ef835033715aec72 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 5 May 2022 16:52:50 +0000 Subject: [PATCH 195/217] adding bug fix from jili dong and removing U* averaging --- physics/module_sf_mynn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index f82597b15..da058139e 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -849,7 +849,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & DO I=its,ite ! CONVERT LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: TH1D(I)=T1D(I)**(100000./P1D(I))**ROVCP !(Theta, K) - TC1D(I)=T1D(I)-273.15 !(T, Celsius) + TC1D(I)=T1D(I)-273.15 !(T, Celsius) ENDDO DO I=its,ite From 63020ec6a737511a46102865458b9843e340a404 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 5 May 2022 22:46:10 +0000 Subject: [PATCH 196/217] Switch to another version of the code that works with 64 bit --- physics/GFS_rrtmgp_cloud_overlap.F90 | 4 ++-- physics/GFS_suite_interstitial_4.F90 | 10 +++++----- physics/cires_ugwp.F90 | 4 ---- physics/cires_ugwpv1_oro.F90 | 2 +- physics/hedmf.f | 2 ++ physics/maximum_hourly_diagnostics.F90 | 14 +++++++------- physics/module_bl_mynn.F90 | 23 ++++++++++++++++++----- physics/module_sf_mynn.F90 | 4 ++-- physics/module_sf_noahmplsm.f90 | 4 ++-- physics/module_sf_ruclsm.F90 | 5 ++--- physics/module_soil_pre.F90 | 24 +++++++++++------------- physics/radiation_gases.f | 2 +- physics/satmedmfvdif.F | 2 -- physics/surface_perturbation.F90 | 2 +- 14 files changed, 54 insertions(+), 48 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 index c1a6c4763..13794641b 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -99,7 +99,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! Cloud overlap parameter ! if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then - call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001_kind_phys, de_lgth, cld_frac, cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001, de_lgth, cld_frac, cloud_overlap_param) else de_lgth(:) = 0. cloud_overlap_param(:,:) = 0. @@ -110,7 +110,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then if (iovr_convcld == iovr_dcorr .or. iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then - call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001_kind_phys, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) else de_lgth(:) = 0. cnv_cloud_overlap_param(:,:) = 0. diff --git a/physics/GFS_suite_interstitial_4.F90 b/physics/GFS_suite_interstitial_4.F90 index 18fcfda09..cbabb991b 100644 --- a/physics/GFS_suite_interstitial_4.F90 +++ b/physics/GFS_suite_interstitial_4.F90 @@ -224,7 +224,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) / (one-spechum(i,k)) !> - Convert number concentration from moist to dry nc_mp(i,k) = gq0(i,k,ntlnc) / (one-spechum(i,k)) - nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(real(qc_mp(i,k) * rho), real(nwfa(i,k)*rho)) * orho) + nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) !> - Convert number concentrations from dry to moist gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) endif @@ -233,7 +233,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) / (one-spechum(i,k)) !> - Convert number concentration from moist to dry ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) - ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(real(qi_mp(i,k) * rho), real(save_tcp(i,k)) * orho)) + ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) !> - Convert number concentrations from dry to moist gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) endif @@ -249,13 +249,13 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr !> - Update cloud water mixing ratio qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) !> - Update cloud water number concentration - gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(real(qc_mp(i,k) * rho), real(nwfa(i,k)*rho)) * orho) + gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) endif if (ntinc>0) then !> - Update cloud ice mixing ratio qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) !> - Update cloud ice number concentration - gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(real(qi_mp(i,k) * rho), real(save_tcp(i,k))) * orho) + gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) endif enddo enddo @@ -290,4 +290,4 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr end subroutine GFS_suite_interstitial_4_run - end module GFS_suite_interstitial_4 + end module GFS_suite_interstitial_4 \ No newline at end of file diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index 2d8eafc19..f2d6b3e3c 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -17,13 +17,9 @@ module cires_ugwp use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize use ugwp_driver_v0 - use gwdps, only: gwdps_run - use cires_ugwp_triggers - use ugwp_driver_v0 - implicit none private diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 index 66d0e472c..959bbd6c5 100644 --- a/physics/cires_ugwpv1_oro.F90 +++ b/physics/cires_ugwpv1_oro.F90 @@ -1,5 +1,5 @@ module cires_ugwpv1_oro - use cires_ugwpv1_sporo + use cires_ugwpv1_sporo contains subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & diff --git a/physics/hedmf.f b/physics/hedmf.f index 604483e53..a1d8df9c3 100644 --- a/physics/hedmf.f +++ b/physics/hedmf.f @@ -5,8 +5,10 @@ !> This module contains the CCPP-compliant hybrid eddy-diffusivity mass-flux !! scheme. module hedmf + use tridi_mod use mfpbl_mod + contains !> \section arg_table_hedmf_init Argument Table diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index ddbff5725..6beae0da2 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -144,11 +144,11 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) real (kind=kind_phys), intent(in) :: grav real (kind=kind_phys), intent(in),dimension(:,:) :: phil,ref3D,tk integer :: i,k,ll,ipt,kpt - real(kind_phys) :: dbz1avg,zmidp1,zmidloc,refl,fact - real(kind_phys), dimension(im,levs) :: z - real(kind_phys), dimension(im) :: zintsfc - real(kind_phys), dimension(:), intent(inout) :: refd,refd263k - REAL(kind_phys) :: dbz1(2),dbzk,dbzk1 + real :: dbz1avg,zmidp1,zmidloc,refl,fact + real, dimension(im,levs) :: z + real, dimension(im) :: zintsfc + real, dimension(:), intent(inout) :: refd,refd263k + REAL :: dbz1(2),dbzk,dbzk1 logical :: counter do i=1,im do k=1,levs @@ -185,7 +185,7 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) dbz1avg=dbz1(2)+(dbz1(2)-dbz1(1))*fact !-- Convert to dBZ (10*logZ) as the last step if (dbz1avg>0.01) then - dbz1avg=10.*log10(dbz1avg) + dbz1avg=10.*alog10(dbz1avg) else dbz1avg=-35. endif @@ -214,7 +214,7 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) dbz1avg=maxval(dbz1) !-- Convert to dBZ (10*logZ) as the last step if (dbz1avg>0.01) then - dbz1avg=10.*log10(dbz1avg) + dbz1avg=10.*alog10(dbz1avg) else dbz1avg=-35. endif diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 334d1db4c..f16ca722a 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -1384,11 +1384,9 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos lb1 = min(dlu,dld) !minimum !JOE-fight floating point errors -#ifdef SINGLE_PREC !JM: keep up the fight, JOE dlu=MAX(0.1,MIN(dlu,1000.)) dld=MAX(0.1,MIN(dld,1000.)) -#endif lb2 = sqrt(dlu*dld) !average - biased towards smallest !lb2 = 0.5*(dlu+dld) !average @@ -1542,11 +1540,9 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos lb1(iz) = min(dlu(iz),dld(iz)) !minimum !JOE-fight floating point errors -#ifdef SINGLE_PREC !JM: keep up the fight, JOE dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) -#endif lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average @@ -2955,8 +2951,12 @@ SUBROUTINE mym_condensation (kts,kte, & zagl = zagl + dz(k) !CLOUD WATER AND ICE - IF (q1k < 0.) THEN !unstaurated + 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.) !Reduce ice mixing ratios in the upper troposphere ! low_weight = MIN(MAX(p(k)-40000.0, 0.0),40000.0)/40000.0 @@ -7608,15 +7608,28 @@ FUNCTION qsat_blend(t, P, waterice) IF ((t .GE. 273.16) .OR. (wrt .EQ. 'w')) THEN ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) +#ifdef SINGLE_PREC qsat_blend = 0.622*ESL/max((P-ESL),1.0E-7_kind_phys) +#else + qsat_blend = 0.622*ESL/(P-ESL) +#endif ELSE IF (t .LE. 253.) THEN ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) +#ifdef SINGLE_PREC qsat_blend = 0.622*ESI/max((P-ESI),1.0E-7_kind_phys) +#else + qsat_blend = 0.622*ESI/(P-ESI) +#endif ELSE ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) +#ifdef SINGLE_PREC RSLF = 0.622*ESL/max((P-ESL),1.0E-7_kind_phys) RSIF = 0.622*ESI/max((P-ESI),1.0E-7_kind_phys) +#else + RSLF = 0.622*ESL/(P-ESL) + RSIF = 0.622*ESI/(P-ESI) +#endif chi = (273.16-t)/20.16 qsat_blend = (1.-chi)*RSLF + chi*RSIF END IF diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index e14c23882..22b142c33 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -2804,8 +2804,8 @@ SUBROUTINE znot_m_v6(uref, znotm) ! znotm(meter): areodynamical roughness scale over water ! - REAL, INTENT(IN) :: uref - REAL, INTENT(OUT):: znotm + REAL(kind=kind_phys), INTENT(IN) :: uref + REAL(kind=kind_phys), INTENT(OUT):: znotm real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02,& & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00,& & p10 = -8.396975715683501e+00, & diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 61b92990b..1c899e4bd 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -681,7 +681,7 @@ subroutine noahmp_sflx (parameters, & logical :: dveg_active !< flag to run dynamic vegetation logical :: crop_active !< flag to run crop model ! add canopy heat storage (C.He added based on GY Niu's communication) - real (kind=kind_phys) :: canhs ! canopy heat storage change w/m2 + real :: canhs ! canopy heat storage change w/m2 ! maximum lai/sai used for some parameterizations based on plant growthi @@ -4494,7 +4494,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,shdfac ,garea1 ,.false. ,0.0_kind_phys,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index a27d0f287..b39610bc8 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -7603,11 +7603,10 @@ END SUBROUTINE SOILIN !>\ingroup lsm_ruc_group !> This function calculates the liquid saturation vapor mixing ratio as !! a function of temperature and pressure (from Thompson scheme). - FUNCTION RSLF(P,T) + REAL FUNCTION RSLF(P,T) IMPLICIT NONE - REAL(kind_phys), INTENT(IN):: P, T - REAL(kind_phys) :: RSLF + REAL, INTENT(IN):: P, T REAL:: ESL,X REAL, PARAMETER:: C0= .611583699E03 REAL, PARAMETER:: C1= .444606896E02 diff --git a/physics/module_soil_pre.F90 b/physics/module_soil_pre.F90 index 149f87a1c..8eb5a5775 100644 --- a/physics/module_soil_pre.F90 +++ b/physics/module_soil_pre.F90 @@ -5,8 +5,6 @@ module module_soil_pre !tgs Initialize RUC LSM levels, soil temp/moisture - use machine, only: kind_phys - implicit none private @@ -28,8 +26,8 @@ SUBROUTINE init_soil_depth_3 ( zs , dzs , num_soil_levels ) INTEGER, INTENT(IN) :: num_soil_levels - REAL(kind_phys), DIMENSION(1:num_soil_levels), INTENT(OUT) :: zs, dzs - REAL(kind_phys), DIMENSION(1:num_soil_levels) :: zs2 + REAL, DIMENSION(1:num_soil_levels), INTENT(OUT) :: zs, dzs + REAL, DIMENSION(1:num_soil_levels) :: zs2 INTEGER :: l @@ -92,21 +90,21 @@ SUBROUTINE init_soil_3_real ( tsk , tmn , smois , tslb , & INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input - REAL(kind_phys) , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input - REAL(kind_phys) , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input - REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input + REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst - REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn - REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk - REAL(kind_phys) , DIMENSION(num_soil_layers) :: zs , dzs + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk + REAL , DIMENSION(num_soil_layers) :: zs , dzs - REAL(kind_phys) , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois - REAL(kind_phys) , ALLOCATABLE , DIMENSION(:) :: zhave + REAL , ALLOCATABLE , DIMENSION(:) :: zhave logical :: debug_print = .false. INTEGER :: i , j , l , lout , lin , lwant , lhave, k - REAL(kind_phys) :: temp + REAL :: temp ! Allocate the soil layer array used for interpolating. diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f index d6f1d7259..157da8e09 100644 --- a/physics/radiation_gases.f +++ b/physics/radiation_gases.f @@ -371,7 +371,7 @@ subroutine gas_init & endif do k = 1, LOZ - pkstr(k) = fpkapx(pstr(k)*100.0_kind_phys) + pkstr(k) = fpkapx(pstr(k)*100.0) enddo endif ! end if_ioznflg_block diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index f791a2de4..c7fe1d5c0 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -4,11 +4,9 @@ !! eddy-diffusion mass-flux (TKE-EDMF) parameterization (by Jongil Han). module satmedmfvdif - use tridi_mod use mfscu_mod use mfpblt_mod - contains !> \section arg_table_satmedmfvdif_init Argument Table diff --git a/physics/surface_perturbation.F90 b/physics/surface_perturbation.F90 index 7ddbe5279..e0429a5fc 100644 --- a/physics/surface_perturbation.F90 +++ b/physics/surface_perturbation.F90 @@ -48,7 +48,7 @@ subroutine cdfnor(z,cdfz) cdfz = 0.5 else x = 0.5*z*z - call cdfgam(x,0.5_kind_phys,del,iflag, cdfx) + call cdfgam(x,0.5,del,iflag, cdfx) if (iflag.ne.0) return if (z.gt.0.0) then cdfz = 0.5+0.5*cdfx From 3b7423b3d97f45a901e077518b0750d6473b03af Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 16:47:23 +0000 Subject: [PATCH 197/217] Remove some commented-out code. --- physics/cu_gf_driver.F90 | 20 -------------------- 1 file changed, 20 deletions(-) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index a9cecb5ce..a87473958 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -39,26 +39,6 @@ subroutine cu_gf_driver_init(imfshalcnv, imfshalcnv_gf, imfdeepcnv, & errmsg = '' errflg = 0 - ! DH* temporary - ! if (mpirank==mpiroot) then - ! write(0,*) ' ----------------------------------------------------------'//& - ! '-------------------------------------------------------------------' - ! write(0,*) ' --- WARNING --- the CCPP Grell Freitas convection scheme is'//& - ! ' currently under development, use at your own risk --- WARNING ---' - ! write(0,*) ' --------------------------------------------------------------------'//& - ! '---------------------------------------------------------' - ! end if - ! *DH temporary - - ! ! Consistency checks - ! if (.not. (imfshalcnv == imfshalcnv_gf .or. & - ! & imfdeepcnv == imfdeepcnv_gf)) then - ! write(errmsg,'(*(a))') 'Logic error: namelist choice of', & - ! & ' convection is different from Grell-Freitas scheme' - ! errflg = 1 - ! return - ! end if - end subroutine cu_gf_driver_init subroutine cu_gf_driver_finalize() From cd410130fcf0de0ea68c7dd98e0ecd0ccb85855f Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 17:44:02 +0000 Subject: [PATCH 198/217] Turn rrtmg smoke band 10 into a model namelist variable --- physics/GFS_rrtmg_pre.F90 | 7 ++++--- physics/GFS_rrtmg_pre.meta | 7 +++++++ 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 57261ef18..106007cdc 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -41,7 +41,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & aero_dir_fdb, smoke_ext, dust_ext, & - spp_wts_rad, spp_rad, errmsg, errflg) + spp_wts_rad, spp_rad, rrfs_smoke_band, errmsg, errflg) use machine, only: kind_phys @@ -109,7 +109,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & iovr_exprand, & ! Flag for exponential-random cloud overlap method idcor_con, & idcor_hogan, & - idcor_oreopoulos + idcor_oreopoulos, & + rrfs_smoke_band ! Band number for rrfs-smoke dust and smoke character(len=3), dimension(:), intent(in) :: lndp_var_list @@ -624,7 +625,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & do k = 1, LMK do i = 1, IM ! 550nm (~18000/cm) - faersw1(i,k,10) = faersw1(i,k,10) + MIN(4.,smoke_ext(i,k) + dust_ext(i,k)) + faersw1(i,k,rrfs_smoke_band) = faersw1(i,k,rrfs_smoke_band) + MIN(4.,smoke_ext(i,k) + dust_ext(i,k)) enddo enddo endif diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 154cb2fab..695ae65ef 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1232,6 +1232,13 @@ dimensions = () type = integer intent = in +[rrfs_smoke_band] + standard_name = rrtmg_band_number_that_smoke_and_dust_should_affect + long_name = rrtmg band number that smoke and dust should affect + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 20cbc054ac168d16b741520617836c0f888beb64 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 18:35:55 +0000 Subject: [PATCH 199/217] Switch arguments to implied shape --- smoke/rrfs_smoke_lsdep_wrapper.F90 | 8 +++---- smoke/rrfs_smoke_postpbl.F90 | 4 ++-- smoke/rrfs_smoke_wrapper.F90 | 36 +++++++++++++++--------------- 3 files changed, 24 insertions(+), 24 deletions(-) diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/smoke/rrfs_smoke_lsdep_wrapper.F90 index d64866f41..aa0574fce 100644 --- a/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ b/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -45,11 +45,11 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & integer, parameter :: ims=1,jms=1,jme=1, kms=1 integer, parameter :: its=1,jts=1,jte=1, kts=1 - real(kind_phys), dimension(im), intent(in) :: rain_cpl, rainc_cpl - real(kind_phys), dimension(im,kme), intent(in) :: ph3d, pr3d - real(kind_phys), dimension(im,kte), intent(in) :: phl3d, prl3d, tk3d, & + real(kind_phys), dimension(:), intent(in) :: rain_cpl, rainc_cpl + real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & us3d, vs3d, spechum, w, dqdt - real(kind_phys), dimension(im,kte,ntrac), intent(inout) :: gq0, qgrs + real(kind_phys), dimension(:,:,:), intent(inout) :: gq0, qgrs integer, intent(in) :: wetdep_ls_opt_in character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/smoke/rrfs_smoke_postpbl.F90 b/smoke/rrfs_smoke_postpbl.F90 index b9d61d42b..f83aaf795 100755 --- a/smoke/rrfs_smoke_postpbl.F90 +++ b/smoke/rrfs_smoke_postpbl.F90 @@ -33,8 +33,8 @@ subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & integer, parameter :: its=1,kts=1 - real(kind_phys), dimension(ite,kte,ntrac), intent(inout) :: qgrs - real(kind_phys), dimension(ite,kte, 2), intent(inout) :: chem3d + real(kind_phys), dimension(:,:,:), intent(inout) :: qgrs + real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 index a179553b6..6d5bff569 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -59,27 +59,27 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, integer, parameter :: ims=1,jms=1,jme=1, kms=1 integer, parameter :: its=1,jts=1,jte=1, kts=1 - integer, dimension(im), intent(in) :: land, vegtype, soiltyp - real(kind_phys), dimension(im,nsoil), intent(in) :: smc - real(kind_phys), dimension(im,12, 5), intent(in) :: dust12m_in - real(kind_phys), dimension(im,24, 3), intent(in) :: smoke_GBBEPx - real(kind_phys), dimension(im, 1), intent(in) :: emi_in - real(kind_phys), dimension(im), intent(in) :: u10m, v10m, ustar, dswsfc, & + integer, dimension(:), intent(in) :: land, vegtype, soiltyp + real(kind_phys), dimension(:,:), intent(in) :: smc + real(kind_phys), dimension(:,:,:), intent(in) :: dust12m_in + real(kind_phys), dimension(:,:,:), intent(in) :: smoke_GBBEPx + real(kind_phys), dimension(:,:), intent(in) :: emi_in + real(kind_phys), dimension(:), intent(in) :: u10m, v10m, ustar, dswsfc, & garea, rlat,rlon, tskin, pb2d, sigmaf, zorl, snow, & rain_cpl, rainc_cpl, hf2d, t2m, dpt2m - real(kind_phys), dimension(im,kme), intent(in) :: ph3d, pr3d - real(kind_phys), dimension(im,kte), intent(in) :: phl3d, prl3d, tk3d, & + real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & us3d, vs3d, spechum, exch, w - real(kind_phys), dimension(im,kte,ntrac), intent(inout) :: qgrs, gq0 - real(kind_phys), dimension(im,kte, 2), intent(inout) :: chem3d - real(kind_phys), dimension(im), intent(inout) :: emdust, emseas, emanoc - real(kind_phys), dimension(im), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr - real(kind_phys), dimension(im ), intent(inout) :: coef_bb, fhist - real(kind_phys), dimension(im,kte), intent(inout) :: ebu_smoke - real(kind_phys), dimension(im), intent(inout) :: max_fplume, min_fplume - real(kind_phys), dimension(im), intent( out) :: hwp - real(kind_phys), dimension(im,kte), intent(out) :: smoke_ext, dust_ext - real(kind_phys), dimension(im,kte), intent(inout) :: nwfa, nifa + real(kind_phys), dimension(:,:,:), intent(inout) :: qgrs, gq0 + real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind_phys), dimension(:), intent(inout) :: emdust, emseas, emanoc + real(kind_phys), dimension(:), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr + real(kind_phys), dimension(:), intent(inout) :: coef_bb, fhist + real(kind_phys), dimension(:,:), intent(inout) :: ebu_smoke + real(kind_phys), dimension(:), intent(inout) :: max_fplume, min_fplume + real(kind_phys), dimension(:), intent( out) :: hwp + real(kind_phys), dimension(:,:), intent(out) :: smoke_ext, dust_ext + real(kind_phys), dimension(:,:), intent(inout) :: nwfa, nifa integer, intent(in ) :: imp_physics, imp_physics_thompson integer, intent(in) :: seas_opt_in, dust_opt_in, biomass_burn_opt_in, & drydep_opt_in, plumerisefire_frq_in, addsmoke_flag_in From f76236fb7d3dfd4716060f45ba49fe7750bebdab Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 20:20:06 +0000 Subject: [PATCH 200/217] Remove some stops and gotos --- smoke/dep_wet_ls_mod.F90 | 19 +++----- smoke/module_plumerise1.F90 | 8 ++-- smoke/module_smoke_plumerise.F90 | 74 +++++++++++++++++++++----------- smoke/rrfs_smoke_data.F90 | 14 +++--- smoke/rrfs_smoke_wrapper.F90 | 3 +- 5 files changed, 73 insertions(+), 45 deletions(-) diff --git a/smoke/dep_wet_ls_mod.F90 b/smoke/dep_wet_ls_mod.F90 index 23ceb803e..2790abc05 100755 --- a/smoke/dep_wet_ls_mod.F90 +++ b/smoke/dep_wet_ls_mod.F90 @@ -305,12 +305,12 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & do nv=1, num_chem ! Loop over spatial indices do j = j1, j2 - do i = i1, i2 + big_i_loop: do i = i1, i2 ! Check for total precipitation amount ! Assume no precip in column if precl+precc = 0 pac = precl(i,j) + precc(i,j) - if(pac .le. 0.) goto 100 + if(pac .le. 0.) cycle big_i_loop pls = precl(i,j) pcv = precc(i,j) @@ -327,12 +327,10 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & do k = k2, k1,-1 !lzhang if(dqcond(i,k,j) .lt. 0. .and. tmpu(i,k,j) .gt. 258.) then LH = k - goto 15 + exit endif end do - 15 continue - !if(LH .lt. 1) goto 100 - if(LH .gt. k2) goto 100 !lzhang + if(LH .gt. k2) cycle big_i_loop !lzhang ! convert dqcond from kg water/kg air/s to kg water/m3/s and reverse ! sign so that dqcond < 0. (positive precip) means qls and qcv > 0. @@ -392,11 +390,10 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & if (Qls(kk).gt.0.) then Qmx = max(Qmx,Qls(kk)) else - goto 333 + exit end if end do - 333 continue F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(Qmx*cdt/Td_ls)) if (F.lt.0.01) F = 0.01 !----------------------------------------------------------------------------- @@ -474,11 +471,10 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & if (Qcv(kk).gt.0.) then Qmx = max(Qmx,Qcv(kk)) else - goto 444 + exit end if end do - 444 continue F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qmx*cdt/Td_cv)) if (F.lt.0.01) F = 0.01 !----------------------------------------------------------------------------- @@ -554,8 +550,7 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k1,n)/cdt ! ug/m2/s end do - 100 continue - end do ! i + end do big_i_loop ! i end do ! j end do !nv for num_chem diff --git a/smoke/module_plumerise1.F90 b/smoke/module_plumerise1.F90 index f3c756b7e..6950fa0cb 100755 --- a/smoke/module_plumerise1.F90 +++ b/smoke/module_plumerise1.F90 @@ -41,7 +41,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & plume_frp, k_min, k_max, & ! RAR: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, errmsg, errflg) use rrfs_smoke_config use physcons @@ -56,7 +56,8 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & real(kind=kind_phys), DIMENSION( ims:ime, jms:jme, 2 ), INTENT(IN ) :: plume_frp ! RAR: FRP etc. array ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg INTEGER, INTENT(IN ) :: ktau, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -187,8 +188,9 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & u_in, v_in, w_in, theta_in ,pi_in, & rho_phyin, qv_in, zmid, z_lev, & plume_frp(i,j,1), k_min(i,j), & - k_max(i,j), ktau, dbg_opt ) + k_max(i,j), ktau, dbg_opt, errmsg, errflg ) !k_max(i,j), ktau, config_flags%debug_chem ) + if(errflg/=0) return kp1= k_min(i,j) kp2= k_max(i,j) diff --git a/smoke/module_smoke_plumerise.F90 b/smoke/module_smoke_plumerise.F90 index a9535f8b1..a3894ac5a 100755 --- a/smoke/module_smoke_plumerise.F90 +++ b/smoke/module_smoke_plumerise.F90 @@ -33,7 +33,7 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! firesize,mean_fct, & ! nspecies,eburn_in,eburn_out, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & - frp_inst,k1,k2, ktau, dbg_opt ) + frp_inst,k1,k2, ktau, dbg_opt, errmsg, errflg ) implicit none type(smoke_data), intent(inout) :: data @@ -49,6 +49,8 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & INTEGER, INTENT (IN) :: ktau INTEGER, INTENT (OUT) :: k1,k2 + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg ! integer :: ncall = 0 integer :: kmt @@ -144,7 +146,8 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! enddo !- get envinronmental state (temp, water vapor mix ratio, ...) - call get_env_condition(coms,1,m1,kmt,wind_eff,ktau) + call get_env_condition(coms,1,m1,kmt,wind_eff,ktau,errmsg,errflg) + if(errflg/=0) return !- loop over the four types of aggregate biomes with fires for plumerise version 1 !- for plumerise version 2, there is exist only one loop @@ -177,7 +180,8 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & END IF !- get fire properties (burned area, plume radius, heating rates ...) - call get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP) + call get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) + if(errflg/=0) return !------ generates the plume rise ------ call makeplume (coms,kmt,ztopmax(imm),ixx,imm) @@ -217,7 +221,7 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & end subroutine plumerise !------------------------------------------------------------------------- -subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau) +subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,errmsg,errflg) !se module_zero_plumegen_coms !use rconstants @@ -227,6 +231,8 @@ subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau) real(kind=kind_phys) :: znz,themax,tlll,plll,rlll,zlll,dzdd,dzlll,tlcl,plcl,dzlcl,dummy !integer :: n_setgrid = 0 integer :: wind_eff,ktau +character(*), intent(inout) :: errmsg +integer, intent(inout) :: errflg if(ktau==2) then ! n_setgrid = 1 @@ -236,20 +242,31 @@ subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau) endif znz=coms%zcon(k2) +errflg=1 do k=nkp,1,-1 - if(coms%zt(k).lt.znz)go to 13 + if(coms%zt(k).lt.znz) then + errflg=0 + exit + endif enddo -stop ' envir stop 12' -13 continue +if(errflg/=0) then + errmsg=' envir stop 12' + return +endif !-srf-mb kmt=min(k,nkp-1) nk=k2-k1+1 -!call htint(nk, coms%wcon,coms%zzcon,kmt,wpe,coms%zt) - call htint(nk, coms%ucon,coms%zcon,kmt,coms%upe,coms%zt) - call htint(nk, coms%vcon,coms%zcon,kmt,coms%vpe,coms%zt) - call htint(nk,coms%thtcon,coms%zcon,kmt,coms%the ,coms%zt) - call htint(nk, coms%rvcon,coms%zcon,kmt,coms%qvenv,coms%zt) +!call htint(nk, coms%wcon,coms%zzcon,kmt,wpe,coms%zt,errmsg,errflg) +!if(errflg/=0) return + call htint(nk, coms%ucon,coms%zcon,kmt,coms%upe,coms%zt,errmsg,errflg) + if(errflg/=0) return + call htint(nk, coms%vcon,coms%zcon,kmt,coms%vpe,coms%zt,errmsg,errflg) + if(errflg/=0) return + call htint(nk,coms%thtcon,coms%zcon,kmt,coms%the ,coms%zt,errmsg,errflg) + if(errflg/=0) return + call htint(nk, coms%rvcon,coms%zcon,kmt,coms%qvenv,coms%zt,errmsg,errflg) + if(errflg/=0) return do k=1,kmt coms%qvenv(k)=max(coms%qvenv(k),1e-8) enddo @@ -422,13 +439,15 @@ SUBROUTINE set_flam_vert(ztopmax,k1,k2,nkp,zzcon) !,W_VMD,VMD) END SUBROUTINE set_flam_vert !------------------------------------------------------------------------- -subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP) +subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) !use module_zero_plumegen_coms implicit none type(plumegen_coms), pointer :: coms integer :: moist, i, icount,imm,iveg_ag !,plumerise_flag real(kind=kind_phys):: bfract, effload, heat, hinc ,burnt_area,heat_fluxW,FRP real(kind=kind_phys), dimension(2,4) :: heat_flux +integer, intent(inout) :: errflg +character(*), intent(inout) :: errmsg INTEGER, parameter :: use_last = 0 !real(kind=kind_phys), parameter :: beta = 5.0 !ref.: Wooster et al., 2005 REAL(kind=kind_phys), parameter :: beta = 0.88 !ref.: Paugam et al., 2015 @@ -522,7 +541,11 @@ subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP) ! except for the first few minutes for stability ICOUNT = 1 ! - if(COMS%MDUR > NTIME) STOP 'Increase time duration (ntime) in min - see file "module_zero_plumegen_coms.F90"' + if(COMS%MDUR > NTIME) then + errmsg = 'Increase time duration (ntime) in min - see file "module_zero_plumegen_coms.F90"' + errflg = 1 + return + endif DO WHILE (ICOUNT.LE.COMS%MDUR) ! COMS%HEATING (ICOUNT) = HEAT * EFFLOAD / COMS%TDUR ! W/m**2 @@ -1933,7 +1956,7 @@ SUBROUTINE EVAPORATE(coms) ! sd is still positive or we wouldn't be here. - IF (COMS%QH (COMS%L) .LE.1.E-10) GOTO 33 + IF (COMS%QH (COMS%L) > 1.E-10) THEN !srf-25082005 ! QUANT = ( COMS%QC (COMS%L) + COMS%QV (COMS%L) - COMS%QSAT (COMS%L) ) * COMS%RHO (COMS%L) !g/m**3 @@ -1982,7 +2005,7 @@ SUBROUTINE EVAPORATE(coms) ! now for ice ! equation from (OT); correction factors for units applied ! - 33 continue + ENDIF IF (COMS%QI (COMS%L) .LE.1.E-10) RETURN !no ice there ! DIVIDEND = ( (1.E6 / COMS%RHO (COMS%L) ) **0.475) * (SD / COMS%QSAT (COMS%L) & @@ -2273,7 +2296,7 @@ SUBROUTINE MELT(coms) ! END SUBROUTINE MELT -SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb) +SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb, errmsg, errflg) IMPLICIT NONE INTEGER, INTENT(IN ) :: nzz1 INTEGER, INTENT(IN ) :: nzz2 @@ -2281,7 +2304,8 @@ SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb) REAL(kind=kind_phys), INTENT(OUT) :: vctrb(nzz2) REAL(kind=kind_phys), INTENT(IN ) :: eleva(nzz1) REAL(kind=kind_phys), INTENT(IN ) :: elevb(nzz2) - + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg INTEGER :: l INTEGER :: k INTEGER :: kk @@ -2308,7 +2332,8 @@ SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb) DO kk=1,l PRINT*,'kk,eleva(kk),elevb(kk)',kk,eleva(kk),elevb(kk) END DO - STOP 'htint' + errmsg='htint assertion failure (see print for details)' + errflg=1 END IF END DO END DO @@ -2331,13 +2356,14 @@ FUNCTION ESAT_PR (TEM) ! ! TEMC = TEM - TMELT -IF (TEMC.GT. - 40.0) GOTO 230 -ESATM = CI1 * EXP (CI2 * TEMC / (TEMC + CI3) ) !ice, millibars -ESAT_PR = ESATM / 10. !kPa +IF (TEMC<= - 40.0) then + ESATM = CI1 * EXP (CI2 * TEMC / (TEMC + CI3) ) !ice, millibars + ESAT_PR = ESATM / 10. !kPa -RETURN + RETURN +ENDIF ! -230 ESATM = CW1 * EXP ( ( (CW2 - (TEMC / CW4) ) * TEMC) / (TEMC + CW3)) +ESATM = CW1 * EXP ( ( (CW2 - (TEMC / CW4) ) * TEMC) / (TEMC + CW3)) ESAT_PR = ESATM / 10. !kPa RETURN diff --git a/smoke/rrfs_smoke_data.F90 b/smoke/rrfs_smoke_data.F90 index f1d11960a..cb9cc25e6 100755 --- a/smoke/rrfs_smoke_data.F90 +++ b/smoke/rrfs_smoke_data.F90 @@ -147,13 +147,15 @@ end subroutine smoke_data_destructor ! SUBROUTINE dep_init( id, numgas, mminlu_loc, & ! ips, ipe, jps, jpe, ide, jde ) - SUBROUTINE dep_init(this) + SUBROUTINE dep_init(this,errmsg,errflg) ! Lifted out of dep_simple_mod, this initializes ! member variables that were module variables in ! that module. !-- implicit none class(smoke_data) :: this + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg !-------------------------------------------------- ! .. Scalar Arguments .. @@ -220,12 +222,14 @@ SUBROUTINE dep_init(this) 0.19E+03, 0.10E+11, 0.10E+11, 0.10E+11/ ! .. IF (nlu/=25) THEN - write(0,*) 'number of land use classifications not correct ' - stop + errmsg='number of land use classifications not correct ' + errflg=1 + return END IF IF (dep_seasons/=5) THEN - write(0,*) 'number of dep_seasons not correct ' - stop + errmsg='number of dep_seasons not correct ' + errflg=1 + return END IF ! SURFACE RESISTANCE DATA FOR DEPOSITION MODEL OF diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 index 6d5bff569..ae7deccbc 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -341,7 +341,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, plume_frp, min_fplume2, max_fplume2, & ! new approach ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, errmsg, errflg ) + if(errflg/=0) return end if ! -- add biomass burning emissions at every timestep From aaca3b0f8bf777aaa10eec8f60b2d43a2ce7d7cb Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 9 May 2022 20:00:23 +0000 Subject: [PATCH 201/217] Remove some hard-coded constants and rename some meta entries --- physics/GFS_rrtmg_pre.meta | 6 +-- physics/mp_thompson.meta | 4 +- physics/mynnedmf_wrapper.meta | 8 +-- smoke/dep_wet_ls_mod.F90 | 5 +- smoke/module_plumerise1.F90 | 11 ++-- smoke/module_smoke_plumerise.F90 | 18 ++++--- smoke/rrfs_smoke_lsdep_wrapper.F90 | 13 +++-- smoke/rrfs_smoke_lsdep_wrapper.meta | 14 +++-- smoke/rrfs_smoke_postpbl.meta | 4 +- smoke/rrfs_smoke_wrapper.F90 | 21 ++++---- smoke/rrfs_smoke_wrapper.meta | 84 ++++++++++++++++++++--------- smoke/seas_mod.F90 | 15 +++--- smoke/seas_ngac_mod.F90 | 4 +- 13 files changed, 126 insertions(+), 81 deletions(-) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 695ae65ef..2543cf58e 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1195,8 +1195,8 @@ kind = kind_phys intent = out [aero_dir_fdb] - standard_name = rrfs_smoke_dust_rad_fdb_opt - long_name = flag for rrfs smoke dust rad feedback + standard_name = do_smoke_aerosol_direct_feedback + long_name = flag for smoke and dust radiation feedback units = flag dimensions = () type = logical @@ -1233,7 +1233,7 @@ type = integer intent = in [rrfs_smoke_band] - standard_name = rrtmg_band_number_that_smoke_and_dust_should_affect + standard_name = index_of_shortwave_band_affected_by_smoke long_name = rrtmg band number that smoke and dust should affect units = count dimensions = () diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 4e82bd982..9981b119d 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -436,8 +436,8 @@ kind = kind_phys intent = in [aero_ind_fdb] - standard_name = rrfs_smoke_aero_ind_fdb_opt - long_name = flag for rrfs wfa ifa emission + standard_name = do_smoke_aerosol_indirect_feedback + long_name = flag for wfa ifa emission indirect feedback units = flag dimensions = () type = logical diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index 7fbb85311..e2a543734 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -1353,21 +1353,21 @@ intent = inout [frp] standard_name = frp_hourly - long_name = hourly frp - units = mw + long_name = hourly fire radiative power + units = MW dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [mix_chem] - standard_name = rrfs_smoke_mynn_tracer_mixing + standard_name = do_planetary_boundary_layer_smoke_mixing long_name = flag for rrfs smoke mynn tracer mixing units = flag dimensions = () type = logical intent = in [fire_turb] - standard_name = rrfs_smoke_mynn_enh_vermix + standard_name = do_planetary_boundary_layer_fire_enhancement long_name = flag for rrfs smoke mynn enh vermix units = flag dimensions = () diff --git a/smoke/dep_wet_ls_mod.F90 b/smoke/dep_wet_ls_mod.F90 index 2790abc05..3a7a186ea 100755 --- a/smoke/dep_wet_ls_mod.F90 +++ b/smoke/dep_wet_ls_mod.F90 @@ -5,7 +5,6 @@ module dep_wet_ls_mod use rrfs_smoke_data use machine , only : kind_phys use rrfs_smoke_config - use physcons, only : grav => con_g ! use chem_tracers_mod ! use chem_rc_mod ! use chem_tracers_mod @@ -206,7 +205,7 @@ end subroutine wetdep_ls subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & num_chem, var_rmv, chem, ple, tmpu, & - rhoa, dqcond, precc, precl, & + rhoa, dqcond, precc, precl, grav, & ims, ime, jms, jme, kms, kme) ! ims, ime, jms, jme, kms, kme, rc ) @@ -217,7 +216,7 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & ! !INPUT PARAMETERS: integer, intent(in) :: i1, i2, j1, j2, k1, k2, n1, n2, num_chem, & ims, ime, jms, jme, kms, kme - real(kind_phys), intent(in) :: cdt + real(kind_phys), intent(in) :: cdt, grav REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem),& INTENT(INOUT) :: chem REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & diff --git a/smoke/module_plumerise1.F90 b/smoke/module_plumerise1.F90 index 6950fa0cb..ee4854308 100755 --- a/smoke/module_plumerise1.F90 +++ b/smoke/module_plumerise1.F90 @@ -5,6 +5,7 @@ module module_plumerise1 use rrfs_smoke_data use machine , only : kind_phys + real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) !- Implementing the fire radiative power (FRP) methodology for biomass burning !- emissions and convective energy estimation. !- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) @@ -37,7 +38,7 @@ module module_plumerise1 subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & t_phy,q_vap, & ! RAR: moist is replaced with q_vap rho_phy,vvel,u_phy,v_phy,p_phy, & - z_at_w,z,ktau, & ! scale_fire_emiss is part of config_flags + z_at_w,z,ktau,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags plume_frp, k_min, k_max, & ! RAR: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -66,6 +67,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & ! INTENT(IN ) :: moist real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT ) :: ebu + real(kind=kind_phys), INTENT(IN ) :: g, con_cp, con_rd real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ebb_smoke real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: flam_frac @@ -87,7 +89,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & !real(kind_phys), dimension (num_ebu) :: eburn_in !real(kind_phys), dimension (kte,num_ebu) :: eburn_out real(kind_phys), dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in, rho_phyin ,qv_in ,zmid, z_lev - real(kind=kind_phys) :: dz_plume + real(kind=kind_phys) :: dz_plume, cpor, con_rocp !INTEGER, PARAMETER :: kfire_max=30 ! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct @@ -111,6 +113,8 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & ! ebu(i,kts,j,p_ebu_pm10) = ebu_in(i,1,j,p_ebu_in_pm10) ! enddo ! enddo + cpor =con_cp/con_rd + con_rocp=con_rd/con_cp IF ( dbg_opt .and. ktau<2000) then WRITE(*,*) 'module_plumerise1: its,ite,jts,jte ', its,ite,jts,jte @@ -188,7 +192,8 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & u_in, v_in, w_in, theta_in ,pi_in, & rho_phyin, qv_in, zmid, z_lev, & plume_frp(i,j,1), k_min(i,j), & - k_max(i,j), ktau, dbg_opt, errmsg, errflg ) + k_max(i,j), ktau, dbg_opt, g, con_cp, & + con_rd, cpor, errmsg, errflg ) !k_max(i,j), ktau, config_flags%debug_chem ) if(errflg/=0) return diff --git a/smoke/module_smoke_plumerise.F90 b/smoke/module_smoke_plumerise.F90 index a3894ac5a..247b09f92 100755 --- a/smoke/module_smoke_plumerise.F90 +++ b/smoke/module_smoke_plumerise.F90 @@ -16,16 +16,13 @@ module module_smoke_plumerise use machine , only : kind_phys use rrfs_smoke_data use rrfs_smoke_config, only : FIRE_OPT_GBBEPx, FIRE_OPT_MODIS - use physcons, only : g => con_g, cp => con_cp, r_d => con_rd, r_v =>con_rv use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std, & !tropical_forest, boreal_forest, savannah, grassland, & wind_eff USE module_zero_plumegen_coms - real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) - real(kind=kind_phys),parameter :: rgas=r_d - real(kind=kind_phys),parameter :: cpor=cp/r_d - real(kind=kind_phys),parameter :: p00=p1000mb + !real(kind=kind_phys),parameter :: rgas=r_d + !real(kind=kind_phys),parameter :: cpor=cp/r_d CONTAINS ! RAR: @@ -33,7 +30,8 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! firesize,mean_fct, & ! nspecies,eburn_in,eburn_out, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & - frp_inst,k1,k2, ktau, dbg_opt, errmsg, errflg ) + frp_inst,k1,k2, ktau, dbg_opt, g, cp, rgas, & + cpor, errmsg, errflg ) implicit none type(smoke_data), intent(inout) :: data @@ -44,6 +42,7 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! integer, intent(in) :: PLUMERISE_flag real(kind=kind_phys) :: frp_inst ! This is the instantenous FRP, at a given time step + real(kind=kind_phys) :: g, cp, rgas, cpor integer :: ng,m1,m2,m3,ia,iz,ja,jz,ibcon,mynum,i,j,k,imm,ixx,ispc !,nspecies @@ -146,7 +145,7 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! enddo !- get envinronmental state (temp, water vapor mix ratio, ...) - call get_env_condition(coms,1,m1,kmt,wind_eff,ktau,errmsg,errflg) + call get_env_condition(coms,1,m1,kmt,wind_eff,ktau,g,cp,rgas,cpor,errmsg,errflg) if(errflg/=0) return !- loop over the four types of aggregate biomes with fires for plumerise version 1 @@ -221,13 +220,16 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & end subroutine plumerise !------------------------------------------------------------------------- -subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,errmsg,errflg) +subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,g,cp,rgas,cpor,errmsg,errflg) !se module_zero_plumegen_coms !use rconstants implicit none type(plumegen_coms), pointer :: coms +real(kind=kind_phys) :: g,cp,rgas,cpor integer :: k1,k2,k,kcon,klcl,kmt,nk,nkmid,i +real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) +real(kind=kind_phys),parameter :: p00=p1000mb real(kind=kind_phys) :: znz,themax,tlll,plll,rlll,zlll,dzdd,dzlll,tlcl,plcl,dzlcl,dummy !integer :: n_setgrid = 0 integer :: wind_eff,ktau diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/smoke/rrfs_smoke_lsdep_wrapper.F90 index aa0574fce..1fd7a2d3f 100644 --- a/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ b/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -4,7 +4,6 @@ module rrfs_smoke_lsdep_wrapper - use physcons, only : g => con_g, pi => con_pi use machine , only : kind_phys use rrfs_smoke_config use dep_wet_ls_mod @@ -28,7 +27,7 @@ module rrfs_smoke_lsdep_wrapper !>\section rrfs_smoke_lsdep_wrapper GSD Chemistry Scheme General Algorithm !> @{ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & - rain_cpl, rainc_cpl, & + rain_cpl, rainc_cpl, g, & pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, & w, dqdt, ntrac,ntsmoke,ntdust, & gq0,qgrs,wetdep_ls_opt_in, & @@ -39,7 +38,7 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & integer, intent(in) :: im,kte,kme,ktau integer, intent(in) :: ntrac,ntsmoke,ntdust - real(kind_phys),intent(in) :: dt + real(kind_phys),intent(in) :: dt,g integer, parameter :: ids=1,jds=1,jde=1, kds=1 integer, parameter :: ims=1,jms=1,jme=1, kms=1 @@ -119,7 +118,7 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & call rrfs_smoke_prep_lsdep(data,ktau,dtstep, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, dqdt, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & - t8w,dqdti,z_at_w,vvel, & + t8w,dqdti,z_at_w,vvel,g, & ntsmoke,ntdust, & ntrac,gq0,num_chem, num_moist, & ppm2ugkg,moist,chem, & @@ -138,7 +137,7 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & case (WDLS_OPT_NGAC) call WetRemovalGOCART(data,its,ite, jts,jte, kts,kte, 1,1, dt, & num_chem,var_rmv,chem,p_phy,t_phy, & - rho_phy,dqdti,rcav,rnav, & + rho_phy,dqdti,rcav,rnav, g, & ims,ime, jms,jme, kms,kme) !if (chem_rc_check(localrc, msg="Failure in NGAC wet removal scheme", & ! file=__FILE__, line=__LINE__, rc=rc)) return @@ -170,7 +169,7 @@ end subroutine rrfs_smoke_lsdep_wrapper_run subroutine rrfs_smoke_prep_lsdep(data,ktau,dtstep, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & - t8w,dqdti,z_at_w,vvel, & + t8w,dqdti,z_at_w,vvel,g, & ntsmoke,ntdust, & ntrac,gq0,num_chem, num_moist, & ppm2ugkg,moist,chem, & @@ -182,7 +181,7 @@ subroutine rrfs_smoke_prep_lsdep(data,ktau,dtstep, & !Chem input configuration integer, intent(in) :: ktau - real(kind=kind_phys), intent(in) :: dtstep + real(kind=kind_phys), intent(in) :: dtstep,g !FV3 input variables integer, intent(in) :: ntrac,ntsmoke,ntdust diff --git a/smoke/rrfs_smoke_lsdep_wrapper.meta b/smoke/rrfs_smoke_lsdep_wrapper.meta index 8a9ff5462..23c71fce8 100755 --- a/smoke/rrfs_smoke_lsdep_wrapper.meta +++ b/smoke/rrfs_smoke_lsdep_wrapper.meta @@ -59,6 +59,14 @@ type = real kind = kind_phys intent = in +[g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in [pr3d] standard_name = air_pressure_at_interface long_name = air pressure at model layer interfaces @@ -147,14 +155,14 @@ type = integer intent = in [ntsmoke] - standard_name = index_for_smoke + standard_name = index_for_smoke_in_tracer_concentration_array long_name = tracer index for smoke units = index dimensions = () type = integer intent = in [ntdust] - standard_name = index_for_dust + standard_name = index_for_dust_in_tracer_concentration_array long_name = tracer index for dust units = index dimensions = () @@ -177,7 +185,7 @@ kind = kind_phys intent = inout [wetdep_ls_opt_in] - standard_name = rrfs_smoke_wetdep_ls_opt + standard_name = control_for_smoke_wet_deposition long_name = rrfs smoke large scale wet deposition option units = index dimensions = () diff --git a/smoke/rrfs_smoke_postpbl.meta b/smoke/rrfs_smoke_postpbl.meta index 45ca60cb4..99aae69f2 100755 --- a/smoke/rrfs_smoke_postpbl.meta +++ b/smoke/rrfs_smoke_postpbl.meta @@ -22,14 +22,14 @@ type = integer intent = in [ntsmoke] - standard_name = index_for_smoke + standard_name = index_for_smoke_in_tracer_concentration_array long_name = tracer index for smoke units = index dimensions = () type = integer intent = in [ntdust] - standard_name = index_for_dust + standard_name = index_for_dust_in_tracer_concentration_array long_name = tracer index for dust units = index dimensions = () diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 index ae7deccbc..ac32e1ad4 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -4,7 +4,6 @@ module rrfs_smoke_wrapper - use physcons, only : g => con_g, pi => con_pi use machine , only : kind_phys use rrfs_smoke_config use dust_data_mod @@ -36,8 +35,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl,snow, & - julian, idat, rain_cpl, rainc_cpl, exch, hf2d, & - dust12m_in, emi_in, smoke_GBBEPx, ntrac, qgrs, gq0, chem3d, tile_num, & + julian, idat, rain_cpl, rainc_cpl, exch, hf2d, g, pi, con_cp, con_rd, & + dust12m_in, emi_in, smoke_GBBEPx, ntrac, qgrs, gq0, chem3d, tile_num, & ntsmoke, ntdust, imp_physics, imp_physics_thompson, & nwfa, nifa, emanoc, & emdust, emseas, ebb_smoke_hr, frp_hr, frp_std_hr, & @@ -52,7 +51,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, integer, intent(in) :: im,kte,kme,ktau,nsoil,tile_num,jdate(8),idat(8) integer, intent(in) :: ntrac, ntsmoke, ntdust - real(kind_phys),intent(in) :: dt, julian + real(kind_phys),intent(in) :: dt, julian, g, pi, con_cp, con_rd logical, intent(in) :: smoke_forecast_in,aero_ind_fdb_in,dbg_opt_in integer, parameter :: ids=1,jds=1,jde=1, kds=1 @@ -138,8 +137,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), parameter :: mean_diameter2= 1.E-6, sigma2=1.8 real(kind_phys), parameter :: kappa_oc = 0.2 real(kind_phys), parameter :: kappa_dust = 0.04 - real(kind_phys), parameter :: fact_wfa = 1.e-9*6.0/pi*exp(4.5*log(sigma1)**2)/mean_diameter1**3 - real(kind_phys), parameter :: fact_ifa = 1.e-9*6.0/pi*exp(4.5*log(sigma2)**2)/mean_diameter2**3 + real(kind_phys) :: fact_wfa, fact_ifa !> -- aerosol density (kg/m3) real(kind_phys), parameter :: density_dust= 2.6e+3, density_sulfate=1.8e+3 real(kind_phys), parameter :: density_oc = 1.4e+3, density_seasalt=2.2e+3 @@ -243,7 +241,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & snow,dust12m_in,emi_in,smoke_GBBEPx, & - hf2d, pb2d, & + hf2d, pb2d, g, pi, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & t8w,exch_h, & @@ -305,7 +303,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, if (seas_opt >= SEAS_OPT_DEFAULT) then call gocart_seasalt_driver(ktau,dt,rri,t_phy,moist, & u_phy,v_phy,chem,rho_phy,dz8w,u10,v10,ust,p8w,tsk, & - xland,xlat,xlong,dxy,g,emis_seas, & + xland,xlat,xlong,dxy,g,emis_seas,pi, & seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -337,7 +335,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, data,flam_frac,ebu_in,ebu, & t_phy,moist(:,:,:,p_qv), & rho_phy,vvel,u_phy,v_phy,p_phy, & - z_at_w,zmid,ktau, & + z_at_w,zmid,ktau,g,con_cp,con_rd, & plume_frp, min_fplume2, max_fplume2, & ! new approach ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -432,6 +430,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! WRITE(*,*) 'rrfs nwfa/nifa 2 at ktau= ',ktau !-- to provide real aerosol emission for Thompson MP if (imp_physics == imp_physics_thompson .and. aero_ind_fdb) then + fact_wfa = 1.e-9*6.0/pi*exp(4.5*log(sigma1)**2)/mean_diameter1**3 + fact_ifa = 1.e-9*6.0/pi*exp(4.5*log(sigma2)**2)/mean_diameter2**3 do i = its, ite do k = kts, kte @@ -463,7 +463,7 @@ subroutine rrfs_smoke_prep( & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & snow_cpl,dust12m_in,emi_in,smoke_GBBEPx, & - hf2d, pb2d, & + hf2d, pb2d, g, pi, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & t8w,exch_h, & @@ -488,6 +488,7 @@ subroutine rrfs_smoke_prep( & integer, intent(in) :: nsoil integer, dimension(ims:ime), intent(in) :: land, vegtype, soiltyp integer, intent(in) :: ntrac + real(kind=kind_phys), intent(in) :: g, pi real(kind=kind_phys), dimension(ims:ime), intent(in) :: & u10m, v10m, ustar, garea, rlat, rlon, ts2d, sigmaf, dswsfc, & zorl, snow_cpl, pb2d, hf2d diff --git a/smoke/rrfs_smoke_wrapper.meta b/smoke/rrfs_smoke_wrapper.meta index 709ea00d1..e09b74ac1 100755 --- a/smoke/rrfs_smoke_wrapper.meta +++ b/smoke/rrfs_smoke_wrapper.meta @@ -317,6 +317,38 @@ type = real kind = kind_phys intent = in +[g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat !of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in [dust12m_in] standard_name = fengsha_dust12m_input long_name = fengsha dust input @@ -380,14 +412,14 @@ type = integer intent = in [ntsmoke] - standard_name = index_for_smoke + standard_name = index_for_smoke_in_tracer_concentration_array long_name = tracer index for smoke units = index dimensions = () type = integer intent = in [ntdust] - standard_name = index_for_dust + standard_name = index_for_dust_in_tracer_concentration_array long_name = tracer index for dust units = index dimensions = () @@ -448,7 +480,7 @@ kind = kind_phys intent = inout [ebb_smoke_hr] - standard_name = surfce_emission_of_smoke + standard_name = surface_smoke_emission long_name = emission of surface smoke units = ug m-2 s-1 dimensions = (horizontal_loop_extent) @@ -457,23 +489,23 @@ intent = inout [frp_hr] standard_name = frp_hourly - long_name = hourly frp - units = mw + long_name = hourly fire radiative power + units = MW dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [frp_std_hr] standard_name = frp_std_hourly - long_name = hourly std frp - units = mw + long_name = hourly stdandard deviation of fire radiative power + units = MW dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [coef_bb] standard_name = coef_bb_dc - long_name = coef bb dc from plumerise + long_name = coef to estimate the fire emission units = none dimensions = (horizontal_loop_extent) type = real @@ -481,38 +513,38 @@ intent = inout [ebu_smoke] standard_name = ebu_smoke - long_name = smoke buffer of ebu + long_name = buffer of vertical fire emission units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout [fhist] - standard_name = fhist - long_name = fire hist + standard_name = fire_hist + long_name = coefficient to scale the fire activity depending on the fire duration units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [min_fplume] - standard_name = min_fplume - long_name = miminum plume height + standard_name = minimum_fire_plume_sigma_pressure_level + long_name = minimum model level of fire plumerise units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [max_fplume] - standard_name = max_fplume - long_name = maximum plume height + standard_name = maximum_fire_plume_sigma_pressure_level + long_name = maximum model level of fire plumerise units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [hwp] - standard_name = rrfs_hwp + standard_name = hourly_wildfire_potential long_name = rrfs hourly fire weather potential units = none dimensions = (horizontal_loop_extent) @@ -536,44 +568,44 @@ kind = kind_phys intent = out [seas_opt_in] - standard_name = rrfs_smoke_sea_salt_opt + standard_name = control_for_smoke_sea_salt long_name = rrfs smoke sea salt emission option units = index dimensions = () type = integer intent = in [dust_opt_in] - standard_name = rrfs_smoke_dust_opt + standard_name = control_for_smoke_dust long_name = rrfs smoke dust chem option units = index dimensions = () type = integer intent = in [biomass_burn_opt_in] - standard_name = rrfs_smoke_biomass_burn_opt + standard_name = control_for_smoke_biomass_burn long_name = rrfs smoke biomass burning option units = index dimensions = () type = integer intent = in [drydep_opt_in] - standard_name = rrfs_smoke_drydep_opt + standard_name = control_for_smoke_dry_deposition long_name = rrfs smoke dry deposition option units = index dimensions = () type = integer intent = in [do_plumerise_in] - standard_name = rrfs_smoke_plumerise_flag + standard_name = do_smoke_plumerise long_name = rrfs smoke plumerise option units = index dimensions = () type = logical intent = in [plumerisefire_frq_in] - standard_name = rrfs_smoke_plumerisefire_frq + standard_name = smoke_plumerise_frequency long_name = rrfs smoke add smoke option - units = index + units = min dimensions = () type = integer intent = in @@ -585,21 +617,21 @@ type = integer intent = in [smoke_forecast_in] - standard_name = rrfs_smoke_smoke_forecast_opt + standard_name = do_smoke_forecast long_name = flag for rrfs smoke forecast units = flag dimensions = () type = logical intent = in [aero_ind_fdb_in] - standard_name = rrfs_smoke_aero_ind_fdb_opt + standard_name = do_smoke_aerosol_indirect_feedback long_name = flag for rrfs wfa ifa emission units = flag dimensions = () type = logical intent = in [dbg_opt_in] - standard_name = rrfs_smoke_plumerise_debug + standard_name = do_smoke_debug long_name = flag for rrfs smoke plumerise debug units = flag dimensions = () diff --git a/smoke/seas_mod.F90 b/smoke/seas_mod.F90 index 78bcef5be..85c861156 100755 --- a/smoke/seas_mod.F90 +++ b/smoke/seas_mod.F90 @@ -4,7 +4,6 @@ module seas_mod use machine , only : kind_phys - use physcons, only : pi=>con_pi ! use chem_rc_mod, only : chem_rc_test ! use chem_tracers_mod, only : p_seas_1, p_seas_2, p_seas_3, p_seas_4, p_seas_5, & ! p_eseas1, p_eseas2, p_eseas3, p_eseas4, p_eseas5, & @@ -31,7 +30,7 @@ module seas_mod subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & v_phy,chem,rho_phy,dz8w,u10,v10,ustar,p8w,tsk, & - xland,xlat,xlong,area,g,emis_seas, & + xland,xlat,xlong,area,g,emis_seas,pi, & seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -65,7 +64,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & dz8w,p8w, & u_phy,v_phy,rho_phy - REAL(kind=kind_phys), INTENT(IN ) :: dt,g + REAL(kind=kind_phys), INTENT(IN ) :: dt,g,pi ! integer, parameter :: p_seas_1=15 integer, parameter :: p_seas_2=16 @@ -141,7 +140,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & airmas1(1,1,1) = airmas(1,1) tc1(1,1,1,:) = tc bems1(1,1,:) = bems - call source_ss( imx, jmx, lmx, number_ss_bins, dt, tc1,ilwi, dxy, w10m, airmas1, bems1,ipr) + call source_ss( imx, jmx, lmx, number_ss_bins, dt, tc1, pi, ilwi, dxy, w10m, airmas1, bems1,ipr) tc = tc1(1,1,1,:) chem(i,kts,j,p_seas_1)=(tc(1)+.75*tc(2))*converi chem(i,kts,j,p_seas_2)=(tc(3)+.25*tc(2))*converi @@ -179,7 +178,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & airmas1(1,1,1) = airmas(1,1) tc1(1,1,1,:) = tc bems1(1,1,:) = bems - call source_ss( imx,jmx,lmx,number_ss_bins, dt, tc1, ilwi, dxy, w10m, airmas1, bems1,ipr) + call source_ss( imx,jmx,lmx,number_ss_bins, dt, tc1, pi, ilwi, dxy, w10m, airmas1, bems1,ipr) tc = tc1(1,1,1,:) bems = bems1(1,1,:) @@ -232,7 +231,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & memissions = 0. nemissions = 0. call SeasaltEmission( ra(n), rb(n), emission_scheme, & - ws10m, ustar(i,j), memissions, nemissions, rc ) + ws10m, ustar(i,j), pi, memissions, nemissions, rc ) ! if (chem_rc_test((rc /= 0), msg="Error in NGAC sea salt scheme", & ! file=__FILE__, line=__LINE__)) return @@ -267,7 +266,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & end subroutine gocart_seasalt_driver - SUBROUTINE source_ss(imx,jmx,lmx,nmx, dt1, tc, & + SUBROUTINE source_ss(imx,jmx,lmx,nmx, dt1, tc, pi, & ilwi, dxy, w10m, airmas, & bems,ipr) @@ -308,7 +307,7 @@ SUBROUTINE source_ss(imx,jmx,lmx,nmx, dt1, tc, & INTEGER, INTENT(IN) :: nmx,imx,jmx,lmx,ipr INTEGER, INTENT(IN) :: ilwi(imx,jmx) - REAL(kind=kind_phys), INTENT(IN) :: dxy(jmx), w10m(imx,jmx) + REAL(kind=kind_phys), INTENT(IN) :: dxy(jmx), w10m(imx,jmx), pi REAL(kind=kind_phys), INTENT(IN) :: airmas(imx,jmx,lmx) REAL(kind=kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) REAL(kind=kind_phys), INTENT(OUT) :: bems(imx,jmx,nmx) diff --git a/smoke/seas_ngac_mod.F90 b/smoke/seas_ngac_mod.F90 index 411635db2..2158d808c 100755 --- a/smoke/seas_ngac_mod.F90 +++ b/smoke/seas_ngac_mod.F90 @@ -18,7 +18,6 @@ module seas_ngac_mod ! use chem_comm_mod, only : chem_comm_isroot use machine , only : kind_phys - use physcons, only : pi=>con_pi implicit none @@ -58,7 +57,7 @@ module seas_ngac_mod ! ! !INTERFACE: ! - subroutine SeasaltEmission ( rLow, rUp, method, w10m, ustar, & + subroutine SeasaltEmission ( rLow, rUp, method, w10m, ustar, pi, & memissions, nemissions, rc ) ! !DESCRIPTION: Calculates the seasalt mass emission flux every timestep. @@ -79,6 +78,7 @@ subroutine SeasaltEmission ( rLow, rUp, method, w10m, ustar, & real(kind=kind_phys), intent(in) :: rLow, rUp ! Dry particle bin edge radii [um] real(kind=kind_phys), intent(in) :: w10m ! 10-m wind speed [m s-1] real(kind=kind_phys), intent(in) :: ustar ! friction velocity [m s-1] + real(kind=kind_phys), intent(in) :: pi ! ratio of a circle's circumference to its diameter integer, intent(in) :: method ! Algorithm to use ! !OUTPUT PARAMETERS: From 552d948c6f824386623b59c0c569994e43c98700 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 9 May 2022 21:16:42 +0000 Subject: [PATCH 202/217] Rename some standard_names, change a unit, and remove a "use physcons" --- physics/mynnedmf_wrapper.meta | 2 +- physics/mynnsfc_wrapper.meta | 12 ++++++------ smoke/module_plumerise1.F90 | 1 - smoke/rrfs_smoke_wrapper.meta | 2 +- 4 files changed, 8 insertions(+), 9 deletions(-) diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index e2a543734..01e8e1d9e 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -1283,7 +1283,7 @@ [bl_mynn_closure] standard_name = control_for_closure_level_in_mellor_yamada_nakanishi_niino_pbl_scheme long_name = flag to determine the closure level for the mynn - units = flag + units = 1 dimensions = () type = real intent = in diff --git a/physics/mynnsfc_wrapper.meta b/physics/mynnsfc_wrapper.meta index 5d30d71f3..d89cc5d35 100644 --- a/physics/mynnsfc_wrapper.meta +++ b/physics/mynnsfc_wrapper.meta @@ -158,28 +158,28 @@ type = integer intent = in [isftcflx] - standard_name = flag_for_thermal_roughness_lengths_over_water_in_mynnsfclay + standard_name = control_for_thermal_roughness_lengths_over_water long_name = flag for thermal roughness lengths over water in mynnsfclay - units = flag + units = 1 dimensions = () type = integer intent = in [iz0tlnd] - standard_name = flag_for_thermal_roughness_lengths_over_land_in_mynnsfclay + standard_name = control_for_thermal_roughness_lengths_over_land long_name = flag for thermal roughness lengths over land in mynnsfclay - units = flag + units = 1 dimensions = () type = integer intent = in [sfclay_compute_flux] - standard_name = flag_for_computing_surface_scalar_fluxes_in_mynnsfclay + standard_name = do_compute_surface_scalar_fluxes long_name = flag for computing surface scalar fluxes in mynnsfclay units = flag dimensions = () type = logical intent = in [sfclay_compute_diag] - standard_name = flag_for_computing_surface_diagnostics_in_mynnsfclay + standard_name = do_compute_surface_diagnostics long_name = flag for computing surface diagnostics in mynnsfclay units = flag dimensions = () diff --git a/smoke/module_plumerise1.F90 b/smoke/module_plumerise1.F90 index ee4854308..47bb4e74a 100755 --- a/smoke/module_plumerise1.F90 +++ b/smoke/module_plumerise1.F90 @@ -45,7 +45,6 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & its,ite, jts,jte, kts,kte, errmsg, errflg) use rrfs_smoke_config - use physcons use plume_data_mod USE module_zero_plumegen_coms USE module_smoke_plumerise diff --git a/smoke/rrfs_smoke_wrapper.meta b/smoke/rrfs_smoke_wrapper.meta index e09b74ac1..ef46b04ea 100755 --- a/smoke/rrfs_smoke_wrapper.meta +++ b/smoke/rrfs_smoke_wrapper.meta @@ -610,7 +610,7 @@ type = integer intent = in [addsmoke_flag_in] - standard_name = rrfs_smoke_addsmoke_flag + standard_name = control_for_smoke_biomass_burning_emissions long_name = rrfs smoke add smoke option units = index dimensions = () From 49c70967f78e3a5d5293bab43c81acc6076cd060 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 10 May 2022 13:49:55 -0400 Subject: [PATCH 203/217] make sure that tsfc_wat is calculated when wet = T --- physics/scm_sfc_flux_spec.F90 | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/physics/scm_sfc_flux_spec.F90 b/physics/scm_sfc_flux_spec.F90 index fc4aaf5d1..bb2c47f48 100644 --- a/physics/scm_sfc_flux_spec.F90 +++ b/physics/scm_sfc_flux_spec.F90 @@ -153,14 +153,11 @@ subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, frland(i) = 1.0_kind_phys cice(i) = 0.0_kind_phys icy(i) = .false. - tsfcl(i) = T_surf(i) !GJF else frland(i) = 0.0_kind_phys if (oceanfrac(i) > 0.0_kind_phys) then if (cice(i) >= min_seaice) then icy(i) = .true. - tisfc(i) = T_surf(i) !GJF - tisfc(i) = max(timin, min(tisfc(i), tgice)) ! This cplice namelist option was added to deal with the ! situation of the FV3ATM-HYCOM coupling without an active sea ! ice (e.g., CICE6) component. By default, the cplice is true @@ -186,8 +183,6 @@ subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, else if (cice(i) >= min_lakeice) then icy(i) = .true. - tisfc(i) = T_surf(i) !GJF - tisfc(i) = max(timin, min(tisfc(i), tgice)) islmsk(i) = 2 else cice(i) = 0.0_kind_phys @@ -198,13 +193,23 @@ subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, if (cice(i) < 1.0_kind_phys) then wet(i) = .true. ! some open lake endif - if (wet(i)) then ! Water - tsfc_wat(i) = T_surf(i) - endif endif endif if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) enddo + + do i = 1, im + if (wet(i)) then + tsfc_wat(i) = T_surf(i) + end if + if (dry(i)) then + tsfcl(i) = T_surf(i) + end if + if (icy(i)) then + tisfc(i) = T_surf(i) + tisfc(i) = max(timin, min(tisfc(i), tgice)) + end if + end do ! to prepare to separate lake from ocean under water category do i = 1, im From b9940633e43fb6b14cfdb908c398b08fb6f1291a Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 16 May 2022 09:16:30 -0600 Subject: [PATCH 204/217] Update rte-rrtmgp submodule --- physics/rte-rrtmgp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index cec1e8e12..f9377e81d 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit cec1e8e12d969c3c8c76574dbe4f40b366419cc7 +Subproject commit f9377e81d33e4f73f4433501186465b84dd1111c From eb1ba70428315983b4e4b8a66da200a0c635bc75 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 16 May 2022 17:45:16 +0000 Subject: [PATCH 205/217] Pass some chemistry varibles to mynn_bl_driver correctly --- physics/module_bl_mynn.F90 | 14 +++++++------- physics/mynnedmf_wrapper.F90 | 5 +++-- physics/mynnedmf_wrapper.meta | 7 +++++++ 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 409fb3740..50685b403 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -397,7 +397,7 @@ SUBROUTINE mynn_bl_driver( & &nchem,kdvel,ndvel, & !Smoke/Chem variables &chem3d, vdep, & &frp,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs - &mix_chem,fire_turb, & ! end smoke/chem variables + &mix_chem,fire_turb,rrfs_smoke, & ! end smoke/chem variables &Tsq,Qsq,Cov, & &RUBLTEN,RVBLTEN,RTHBLTEN, & @@ -457,7 +457,7 @@ SUBROUTINE mynn_bl_driver( & LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& FLAG_QNWFA,FLAG_QNIFA - LOGICAL, INTENT(IN) :: mix_chem,fire_turb + LOGICAL, INTENT(IN) :: mix_chem,fire_turb,rrfs_smoke INTEGER, INTENT(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & @@ -537,9 +537,9 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel ! REAL, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), optional :: chem3d ! REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), optional :: vdep - REAL, DIMENSION(ims:ime, kms:kme, nchem), INTENT(INOUT), optional :: chem3d - REAL, DIMENSION(ims:ime, ndvel), INTENT(IN), optional :: vdep - REAL, DIMENSION(ims:ime), INTENT(IN), optional :: frp,EMIS_ANT_NO + REAL, DIMENSION(:, :, :), INTENT(INOUT) :: chem3d + REAL, DIMENSION(:, :), INTENT(IN) :: vdep + REAL, DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO !local REAL, DIMENSION(kts:kte ,nchem) :: chem1 REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 @@ -1047,7 +1047,7 @@ SUBROUTINE mynn_bl_driver( & ENDDO ! end k !initialize smoke/chem arrays (if used): - IF (mix_chem ) then + IF ( rrfs_smoke .and. mix_chem ) then do ic = 1,ndvel vd1(ic) = vdep(i,ic) !is this correct???? chem1(kts,ic) = chem3d(i,kts,ic) @@ -1357,7 +1357,7 @@ SUBROUTINE mynn_bl_driver( & &frp(i), & &fire_turb ) - IF ( PRESENT(chem3d) ) THEN + IF ( rrfs_smoke ) THEN DO ic = 1,nchem DO k = kts,kte chem3d(i,k,ic) = chem1(k,ic) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 744a07e51..a5a1d9240 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -161,7 +161,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & chem3d, frp, mix_chem, fire_turb, nchem, ndvel, & + & chem3d, frp, mix_chem, rrfs_smoke, fire_turb, nchem, ndvel, & & imp_physics_nssl, nssl_ccn_on, & & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) @@ -290,7 +290,7 @@ SUBROUTINE mynnedmf_wrapper_run( & !smoke/chem arrays real(kind_phys), dimension(:), intent(inout) :: frp - logical, intent(in) :: mix_chem, fire_turb + logical, intent(in) :: mix_chem, fire_turb, rrfs_smoke real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d real(kind=kind_phys), dimension(im) :: emis_ant_no real(kind=kind_phys), dimension(im,ndvel) :: vdep @@ -720,6 +720,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & Chem3d=chem3d,Vdep=vdep, & & FRP=frp,EMIS_ANT_NO=emis_ant_no, & & mix_chem=mix_chem,fire_turb=fire_turb, & + & rrfs_smoke=rrfs_smoke, & !----- & Tsq=tsq,Qsq=qsq,Cov=cov, & !output & RUBLTEN=RUBLTEN,RVBLTEN=RVBLTEN,RTHBLTEN=RTHBLTEN, & !output diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index 01e8e1d9e..33f97113f 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -1359,6 +1359,13 @@ type = real kind = kind_phys intent = inout +[rrfs_smoke] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_smoke collection (default off) + units = flag + dimensions = () + type = logical + intent = in [mix_chem] standard_name = do_planetary_boundary_layer_smoke_mixing long_name = flag for rrfs smoke mynn tracer mixing From 1a70737a39d57b525cf1e73604f203a6c6dc7b6e Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Mon, 16 May 2022 14:33:23 -0600 Subject: [PATCH 206/217] Correct argument passing within mynn edmf --- physics/module_bl_mynn.F90 | 97 +++++++++++++++++++----------------- physics/mynnedmf_wrapper.F90 | 5 +- 2 files changed, 54 insertions(+), 48 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 50685b403..8ffd8040c 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -430,7 +430,8 @@ SUBROUTINE mynn_bl_driver( & &spp_pbl,pattern_spp_pbl, & &RTHRATEN, & &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA & + &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & + &FLAG_OZONE & &,IDS,IDE,JDS,JDE,KDS,KDE & &,IMS,IME,JMS,JME,KMS,KME & &,ITS,ITE,JTS,JTE,KTS,KTE) @@ -455,7 +456,7 @@ SUBROUTINE mynn_bl_driver( & REAL, INTENT(in) :: closure LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA + FLAG_QNWFA,FLAG_QNIFA,FLAG_OZONE LOGICAL, INTENT(IN) :: mix_chem,fire_turb,rrfs_smoke @@ -474,61 +475,65 @@ SUBROUTINE mynn_bl_driver( & ! closure : <= 2.5; Level 2.5 ! 2.5< and <3; Level 2.6 ! = 3; Level 3 + +! SGT: Changed this to use assumed shape arrays (dimension(:,:,:)) with no "optional" arguments +! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs +! on Cheyenne with the GNU compiler. REAL, INTENT(in) :: delt - REAL, DIMENSION(IMS:IME), INTENT(in) :: dx - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz, & + REAL, DIMENSION(:), INTENT(in) :: dx + REAL, DIMENSION(:,:), INTENT(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: & + REAL, DIMENSION(:,:), INTENT(in):: & &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: ozone - REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust, & + REAL, DIMENSION(:,:), INTENT(in):: ozone + REAL, DIMENSION(:), INTENT(in) :: xland,ust, & &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov,qke_adv - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN, & &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & &RQNWFABLTEN,RQNIFABLTEN - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: DOZONE + REAL, DIMENSION(:,:), INTENT(inout) :: DOZONE - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN + REAL, DIMENSION(:,:), INTENT(in) :: RTHRATEN - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & + REAL, DIMENSION(:,:), INTENT(out) :: & &exch_h,exch_m !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D ! REAL, DIMENSION(IMS:IME,KMS:KME) :: & ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - REAL, DIMENSION(IMS:IME), INTENT(inout) :: Pblh,rmol + REAL, DIMENSION(:), INTENT(inout) :: Pblh,rmol REAL, DIMENSION(IMS:IME) :: Psig_bl,Psig_shcu - INTEGER,DIMENSION(IMS:IME),INTENT(INOUT) :: & + INTEGER,DIMENSION(:),INTENT(INOUT) :: & &KPBL,nupdraft,ktop_plume - REAL, DIMENSION(IMS:IME), INTENT(OUT) :: & + REAL, DIMENSION(:), INTENT(OUT) :: & &maxmf - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & &el_pbl - REAL, DIMENSION(IMS:IME,KMS:KME), optional, INTENT(out) :: & + REAL, DIMENSION(:,:), INTENT(out) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when bl_mynn_tkebudget == .false. ! 1D (local) budget arrays are used for passing between subroutines. REAL, DIMENSION(kts:kte) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat - REAL, DIMENSION(IMS:IME,KMS:KME), intent(out) :: Sh3D,Sm3D + REAL, DIMENSION(:,:), intent(out) :: Sh3D,Sm3D - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old @@ -586,7 +591,7 @@ SUBROUTINE mynn_bl_driver( & ! Stochastic fields INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl + REAL, DIMENSION( :, :), INTENT(IN) ::pattern_spp_pbl REAL, DIMENSION(KTS:KTE) ::rstoch_col ! Substepping TKE @@ -736,7 +741,7 @@ SUBROUTINE mynn_bl_driver( & QC_BL1D(k)=QC_BL(i,k) QI_BL1D(k)=QI_BL(i,k) ENDIF - IF (PRESENT(sqi3D) .AND. FLAG_QI ) THEN + IF (FLAG_QI ) THEN sqi(k)=sqi3D(i,k) !/(1.+qv(i,k)) sqw(k)=sqv(k)+sqc(k)+sqi(k) thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & @@ -920,7 +925,7 @@ SUBROUTINE mynn_bl_driver( & dqnwfa1(k)=0.0 dqnifa1(k)=0.0 dozone1(k)=0.0 - IF(PRESENT(sqi3D) .AND. FLAG_QI)THEN + IF(FLAG_QI)THEN sqi(k)= sqi3D(i,k) !/(1.+qv(i,k)) qi1(k)= sqi(k)/(1.-sqv(k)) sqw(k)= sqv(k)+sqc(k)+sqi(k) @@ -963,27 +968,27 @@ SUBROUTINE mynn_bl_driver( & thetav(k)=th1(k)*(1.+0.608*sqv(k)) thvl(k) =thlsg(k) *(1.+0.608*sqv(k)) - IF (PRESENT(qni) .AND. FLAG_QNI ) THEN + IF (FLAG_QNI ) THEN qni1(k)=qni(i,k) ELSE qni1(k)=0.0 ENDIF - IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN + IF (FLAG_QNC ) THEN qnc1(k)=qnc(i,k) ELSE qnc1(k)=0.0 ENDIF - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA ) THEN + IF (FLAG_QNWFA ) THEN qnwfa1(k)=qnwfa(i,k) ELSE qnwfa1(k)=0.0 ENDIF - IF (PRESENT(qnifa) .AND. FLAG_QNIFA ) THEN + IF (FLAG_QNIFA ) THEN qnifa1(k)=qnifa(i,k) ELSE qnifa1(k)=0.0 ENDIF - IF (PRESENT(ozone)) THEN + IF (FLAG_OZONE) THEN ozone1(k)=ozone(i,k) ELSE ozone1(k)=0.0 @@ -1344,7 +1349,7 @@ SUBROUTINE mynn_bl_driver( & &bl_mynn_mixscalars ) - IF ( mix_chem ) THEN + IF ( rrfs_smoke .and. mix_chem ) THEN CALL mynn_mix_chem(kts,kte,i, & &delt, dz1, pblh(i), & &nchem, kdvel, ndvel, & @@ -1357,13 +1362,11 @@ SUBROUTINE mynn_bl_driver( & &frp(i), & &fire_turb ) - IF ( rrfs_smoke ) THEN - DO ic = 1,nchem - DO k = kts,kte - chem3d(i,k,ic) = chem1(k,ic) - ENDDO + DO ic = 1,nchem + DO k = kts,kte + chem3d(i,k,ic) = chem1(k,ic) ENDDO - ENDIF + ENDDO ENDIF CALL retrieve_exchange_coeffs(kts,kte,& @@ -1378,22 +1381,22 @@ SUBROUTINE mynn_bl_driver( & RTHBLTEN(i,k)=dth1(k) RQVBLTEN(i,k)=dqv1(k) IF(bl_mynn_cloudmix > 0)THEN - IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k)=dqc1(k) - IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k)=dqi1(k) + IF (FLAG_QC) RQCBLTEN(i,k)=dqc1(k) + IF (FLAG_QI) RQIBLTEN(i,k)=dqi1(k) ELSE - IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k)=0. - IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k)=0. + IF (FLAG_QC) RQCBLTEN(i,k)=0. + IF (FLAG_QI) RQIBLTEN(i,k)=0. ENDIF IF(bl_mynn_cloudmix > 0 .AND. bl_mynn_mixscalars > 0)THEN - IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k)=dqnc1(k) - IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k)=dqni1(k) - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k)=dqnwfa1(k) - IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k)=dqnifa1(k) + IF (FLAG_QNC) RQNCBLTEN(i,k)=dqnc1(k) + IF (FLAG_QNI) RQNIBLTEN(i,k)=dqni1(k) + IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=dqnwfa1(k) + IF (FLAG_QNIFA) RQNIFABLTEN(i,k)=dqnifa1(k) ELSE - IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k)=0. - IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k)=0. - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k)=0. - IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k)=0. + IF (FLAG_QNC) RQNCBLTEN(i,k)=0. + IF (FLAG_QNI) RQNIBLTEN(i,k)=0. + IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=0. + IF (FLAG_QNIFA) RQNIFABLTEN(i,k)=0. ENDIF DOZONE(i,k)=DOZONE1(k) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index a5a1d9240..5917145fe 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -225,7 +225,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_mixscalars=1 LOGICAL :: & & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & - & FLAG_QNWFA, FLAG_QNIFA + & FLAG_QNWFA, FLAG_QNIFA, FLAG_OZONE ! Define locally until needed from CCPP LOGICAL, PARAMETER :: cycling = .false. INTEGER, PARAMETER :: param_first_scalar = 1 @@ -389,6 +389,8 @@ SUBROUTINE mynnedmf_wrapper_run( & t3d(i,:) ) enddo + FLAG_OZONE = ntoz>0 + ! Assign variables for each microphysics scheme if (imp_physics == imp_physics_wsm6) then ! WSM6 @@ -757,6 +759,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & FLAG_QI=flag_qi,FLAG_QNI=flag_qni, & !input & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc, & !input & FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA, & !input + & FLAG_OZONE=FLAG_OZONE, & !input & IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs, & !input & IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs, & !input & ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs) !input From d40f5e2b55d1215900e46b2960e3812774ecf337 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 17 May 2022 22:16:31 +0000 Subject: [PATCH 207/217] Change to GSL CODEOWNERS --- CODEOWNERS | 131 +---------------------------------------------------- 1 file changed, 1 insertion(+), 130 deletions(-) diff --git a/CODEOWNERS b/CODEOWNERS index cf7a886aa..1ac1dbe7c 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -1,138 +1,9 @@ -######################################################################## - -# CODEOWNERS RULES (syntax guide is at end of file) - -# Default codeowners for files that don't have specific owners: - -* @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - - -# The following lines are from the CCPP Primary Schemes Points of Contact -# https://docs.google.com/spreadsheets/d/14y0Th_sSpCqlssEMNfSZ_Ni9wrpPqfpPY0kRG7jCZB8/edit#gid=0 -# (Internal NOAA document.) - -smoke/* @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/cs_conv_aw_adj.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cs_conv.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cu_gf* @hannahcbarnes @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sascnvn.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cu_ntiedtke* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/rascnv.* @SMoorthi-emc @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/samfdeepcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/samfshalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/samfaerosols.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/shalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/unified_ugwp* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/ugwp_driver_v0.F @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cires_ugwp* @mdtoyNOAA @ValeryYudin-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/drag_suite.* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gwdc.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gwdps.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gfdl_fv_sat_adj.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/multi_gases.F90 @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/mp_fer_hires.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MP_FER_HIRES.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/precpd.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gscond.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/m_micro* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/ozphys* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/satmedmfvdif.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/satmedmfvdifq.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfpbl.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfscu.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfpbltq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfscuq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/shinhongvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/ysuvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich - -physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @JongilHan66 @WeiguoWang-NOAA @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich - -physics/moninedmf.* @JongilHan66 @WeiguoWang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_BL_MYJPBL.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MYJPBL_wrapper.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_bl_mynn.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MYNNPBL_wrapper.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gcm_shoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/moninshoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/rte-rrtmgp @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radiation_tools.* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rrtmgp_lw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rrtmgp_sw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/radlw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/HWRF_mcica_random_numbers.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/HWRF_mersenne_twister.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radlw_datatb.f @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radsw_datatb.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radsw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/radsw_param.f @dustinswales @Qingfu-Liu @mjiacono @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/rayleigh_damp.* @yangfanglin @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/flake* @YihuaWu-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_drv.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sflx.f @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/surface_perturbation.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/*noahmp* @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/namelist_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/set_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_sf_ruclsm.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_soil_pre.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_drv_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/date_def.f @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/*nst* @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_ocean.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_diff.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/h2ophys.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_sice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_cice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -######################################################################## - # Lines starting with '#' are comments. # Each line is a file pattern followed by one or more owners. # These owners will be the default owners for everything in the repo. #* @defunkt +* @SamuelTrahanNOAA @tanyasmirnova @christinaholtNOAA @joeolson42 @hannahcbarnes @mdtoyNOAA @haiqinli @zhanglikate @middlecoff # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From eccf83a8b8241850bb9c5a47f0d73c4629a6d0c2 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Wed, 18 May 2022 17:53:05 +0000 Subject: [PATCH 208/217] Returned the comments on soil resistance back. --- physics/module_sf_ruclsm.F90 | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 0cf820303..01e9c1100 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -2581,6 +2581,21 @@ SUBROUTINE SOIL (debug_print, & ! print *,'alfa=',alfa, exp(G0_P*psit/r_v/SOILT) ! endif alfa=1. +! field capacity +! 20jun18 - beta in Eq. (5) is called soilres in the code - it limits soil evaporation +! when soil moisture is below field capacity. [Lee and Pielke, 1992] +! This formulation agrees with obsevations when top layer is < 2 cm thick. +! Soilres = 1 for snow, glaciers and wetland. +! fc=ref - suggested in the paper +! fc=max(qmin,ref*0.5) ! used prior to 20jun18 change +! Switch from ref*0.5 to ref*0.25 will reduce soil resistance, increase direct +! evaporation, effects sparsely vegetated areas--> cooler during the day +! fc=max(qmin,ref*0.25) ! +! For now we'll go back to ref*0.5 +! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct +! evaporation. Therefore , it is replaced with ref*0.7. + !fc=max(qmin,ref*0.5) + !fc=max(qmin,ref*0.7) fc=ref fex_fc=1. if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then From 6f38cc6e83526f907ec2c34712eb230d677f4a2a Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Wed, 18 May 2022 23:58:09 +0000 Subject: [PATCH 209/217] address some review comments, fix decomposition error, correct bug in initialization --- physics/GFS_suite_interstitial_3.F90 | 37 +++++++++-- physics/GFS_suite_interstitial_3.meta | 73 +++++++++++++++++++++ physics/progsigma_calc.f90 | 93 ++++++++++++--------------- physics/samfdeepcnv.f | 22 ++----- physics/samfdeepcnv.meta | 8 --- physics/samfshalcnv.f | 20 +++--- 6 files changed, 162 insertions(+), 91 deletions(-) diff --git a/physics/GFS_suite_interstitial_3.F90 b/physics/GFS_suite_interstitial_3.F90 index 79ab481ec..9fa7d69b7 100644 --- a/physics/GFS_suite_interstitial_3.F90 +++ b/physics/GFS_suite_interstitial_3.F90 @@ -9,10 +9,13 @@ module GFS_suite_interstitial_3 !! \htmlinclude GFS_suite_interstitial_3_run.html !! subroutine GFS_suite_interstitial_3_run (otsptflag, & - im, levs, nn, cscnv, & + im, levs, nn, cscnv,imfshalcnv, imfdeepcnv, & + imfshalcnv_samf, imfdeepcnv_samf,progsigma, & + first_time_step, restart, & satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & - xlon, xlat, gt0, gq0, imp_physics, imp_physics_mg, & + xlon, xlat, gt0, gq0, sigmain,sigmaout,qmicro, & + imp_physics, imp_physics_mg, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, dtidx, ntlnc, & imp_physics_wsm6, imp_physics_fer_hires, prsi, ntinc, & @@ -33,8 +36,9 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & imp_physics_nssl, me, index_of_process_conv_trans integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver - logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras - + logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras, progsigma + logical, intent(in ) :: first_time_step, restart + integer, intent(in ) :: imfshalcnv, imfdeepcnv, imfshalcnv_samf,imfdeepcnv_samf integer, intent(in) :: ntinc, ntlnc logical, intent(in) :: ldiag3d, qdiag3d integer, dimension(:,:), intent(in) :: dtidx @@ -48,6 +52,8 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & real(kind=kind_phys), intent(in ), dimension(:,:) :: gt0 real(kind=kind_phys), intent(in ), dimension(:,:,:) :: gq0 + real(kind=kind_phys), intent(out ), dimension(:,:) :: sigmain + real(kind=kind_phys), intent(out ), dimension(:,:) :: sigmaout,qmicro real(kind=kind_phys), intent(inout), dimension(:,:) :: rhc, save_qc ! save_qi is not allocated for Zhao-Carr MP real(kind=kind_phys), intent(inout), dimension(:,:) :: save_qi @@ -73,6 +79,27 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & errmsg = '' errflg = 0 + ! In case of using prognostic updraf area fraction, initialize area fraction here + ! since progsigma_calc is called from both deep and shallow schemes. + if(((imfshalcnv == imfshalcnv_samf) .or. (imfdeepcnv == imfdeepcnv_samf)) & + .and. progsigma)then + if(first_time_step .and. .not. restart)then + do k=1,levs + do i=1,im + sigmain(i,k)=0.0 + sigmaout(i,k)=0.0 + qmicro(i,k)=0.0 + enddo + enddo + endif + do k=1,levs + do i=1,im + sigmaout(i,k)=0.0 + enddo + enddo + endif + + if (cscnv .or. satmedmf .or. trans_trac .or. ras) then tracers = 2 do n=2,ntrac @@ -192,4 +219,4 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & end subroutine GFS_suite_interstitial_3_run - end module GFS_suite_interstitial_3 \ No newline at end of file + end module GFS_suite_interstitial_3 diff --git a/physics/GFS_suite_interstitial_3.meta b/physics/GFS_suite_interstitial_3.meta index 22a11d0ea..fbeb9f03c 100644 --- a/physics/GFS_suite_interstitial_3.meta +++ b/physics/GFS_suite_interstitial_3.meta @@ -43,6 +43,55 @@ dimensions = () type = logical intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_samf] + standard_name = identifer_for_scale_aware_mass_flux_deep_convection + long_name = flag for SAMF deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfshalcnv] + standard_name = control_for_shallow_convection_scheme + long_name = flag for mass-flux shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfshalcnv_samf] + standard_name = identifier_for_scale_aware_mass_flux_shallow_convection + long_name = flag for SAMF shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[progsigma] + standard_name = do_prognostic_updraft_area_fraction + long_name = flag for prognostic sigma in cumuls scheme + units = flag + dimensions = () + type = logical + intent = in +[first_time_step] + standard_name = flag_for_first_timestep + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in [satmedmf] standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL long_name = flag for scale-aware TKE moist EDMF PBL scheme @@ -173,6 +222,30 @@ type = real kind = kind_phys intent = in +[sigmain] + standard_name = prognostic_updraft_area_fraction_in_convection + long_name = convective updraft area fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[sigmaout] + standard_name = updraft_area_fraction_updated_by_physics + long_name = convective updraft area fraction updated by physics + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[qmicro] + standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics + long_name = moisture tendency due to microphysics + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index fe74dc0c1..49a5e2a4f 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -14,9 +14,9 @@ !> @{ subroutine progsigma_calc (im,km,flag_init,flag_restart, & - flag_shallow,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & - delt,prevsq,q,kbcon1,ktcon,cnvflg,gdx, & - sigmain,sigmaout,sigmab,errmsg,errflg) + del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & + delt,prevsq,q,kbcon1,ktcon,cnvflg,sigmain,sigmaout, & + sigmab,errmsg,errflg) ! ! use machine, only : kind_phys @@ -29,8 +29,8 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & real(kind=kind_phys), intent(in) :: hvap,delt real(kind=kind_phys), intent(in) :: prevsq(im,km), q(im,km),del(im,km), & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & - omega_u(im,km),zeta(im,km),gdx(im) - logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow + omega_u(im,km),zeta(im,km) + logical, intent(in) :: flag_init,flag_restart,cnvflg(im) real(kind=kind_phys), intent(in) :: sigmain(im,km) ! intent out @@ -41,21 +41,20 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! Local variables integer :: i,k,km1 - real(kind=kind_phys) :: termA(im),termB(im),termC(im),termD(im), & - mcons(im),fdqa(im),form(im,km), & - qadv(im,km),sigmamax(im),dp(im,km),inbu(im,km) + real(kind=kind_phys) :: termA(im),termB(im),termC(im),termD(im) + real(kind=kind_phys) :: mcons(im),fdqa(im),form(im,km), & + qadv(im,km),dp(im,km),inbu(im,km) real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, & fdqb,dtdyn,dxlim,rmulacvg,tem, & - alpha,DEN,betascu,dp1,invdelt + DEN,betascu,dp1,invdelt !Parameters gcvalmx = 0.1 rmulacvg=10. epsilon=1.E-11 km1=km-1 - alpha=7000. betascu = 3.0 invdelt = 1./delt @@ -70,10 +69,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & !Initialization 1D do i=1,im - if(cnvflg(i))then - sigmab(i)=0. - endif - sigmamax(i)=0.95 + sigmab(i)=0. termA(i)=0. termB(i)=0. termC(i)=0. @@ -82,6 +78,21 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & mcons(i)=0. enddo + !Initial computations, dynamic q-tendency + if(flag_init .and. .not.flag_restart)then + do k = 1,km + do i = 1,im + qadv(i,k)=0. + enddo + enddo + else + do k = 1,km + do i = 1,im + qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt + enddo + enddo + endif + do k = 2,km1 do i = 1,im if(cnvflg(i))then @@ -102,33 +113,13 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & enddo do i=1,im - if(sigmab(i) < 1.E-5)then !after advection - sigmab(i)=0. + if(cnvflg(i))then + if(sigmab(i) < 1.E-5)then !after advection + sigmab(i)=0. + endif endif enddo - - !Initial computations, sigmamax - do i=1,im - sigmamax(i)=alpha/gdx(i) - sigmamax(i)=MIN(0.95,sigmamax(i)) - enddo - - !Initial computations, dynamic q-tendency - if(flag_init .and. .not.flag_restart)then - do k = 1,km - do i = 1,im - qadv(i,k)=0. - enddo - enddo - else - do k = 1,km - do i = 1,im - qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt - enddo - enddo - endif - - + !compute termD "The vertical integral of the latent heat convergence is limited to the !buoyant layers with positive moisture convergence (accumulated from the surface). !Lowest level: @@ -194,7 +185,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & endif enddo else - do i = 1,im + do i = 1,im if(cnvflg(i))then DEN=MIN(termC(i)+termB(i),1.E8) cvg=termD(i)*delt @@ -204,7 +195,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & cvg=MAX(0.0,cvg) sigmab(i)=(ZZ*(termA(i)+cvg))/(DEN+(1.0-ZZ)) if(sigmab(i)>0.)then - sigmab(i)=MIN(sigmab(i),sigmamax(i)) + sigmab(i)=MIN(sigmab(i),0.95) sigmab(i)=MAX(sigmab(i),0.01) endif endif!cnvflg @@ -218,19 +209,15 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & endif enddo enddo - - !Since updraft velocity is much lower in shallow cu region, termC becomes small in shallow cu application, thus the area fraction - !in this regime becomes too large compared with the deep cu region. To address this simply apply a scaling factor for shallow cu - !before computing the massflux to reduce the total strength of the SC MF: - - if(flag_shallow)then - do i= 1, im - if(cnvflg(i)) then - sigmab(i)=sigmab(i)/betascu - endif - enddo - endif + !Reduce area fraction before coupling back to mass-flux computation. + !This tuning could be addressed in updraft velocity equation instead. + do i= 1, im + if(cnvflg(i)) then + sigmab(i)=sigmab(i)/betascu + endif + enddo + end subroutine progsigma_calc diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 8398af769..3968061a2 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -86,7 +86,7 @@ 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, & - & ca_micro, rainevap, sigmain, sigmaout, errmsg,errflg) + & rainevap,sigmain, sigmaout, errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -107,7 +107,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & & tmf(:,:),q(:,:), prevsq(:,:) - real(kind=kind_phys), intent(out) :: rainevap(:), ca_micro(:) + 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 @@ -214,8 +214,7 @@ 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),qlks(im,km), - & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im) - logical flag_shallow + & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im) real(kind=kind_phys) gravinv c physical parameters ! parameter(grav=grav,asolfac=0.958) @@ -2884,25 +2883,14 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & !> - From Bengtsson et al. (2022) Prognostic closure scheme, equation 8, compute updraft area fraction based on a moisture budget if(progsigma)then - flag_shallow = .false. - call progsigma_calc(im,km,first_time_step,restart,flag_shallow, + call progsigma_calc(im,km,first_time_step,restart, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & prevsq,q,kbcon1,ktcon,cnvflg,gdx, + & prevsq,q,kbcon1,ktcon,cnvflg, & sigmain,sigmaout,sigmab,errmsg,errflg) 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. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. - - do i=1,im - ca_micro(i)=0. - enddo - - do i=1,im - if(cnvflg(i))then - ca_micro(i)=sigmab(i) - endif - enddo do i= 1, im if(cnvflg(i) .and. .not.asqecflg(i)) then diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 1764a74fd..3f28035b6 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -652,14 +652,6 @@ type = real kind = kind_phys intent = in -[ca_micro] - standard_name = output_prognostic_sigma_two - long_name = output of prognostic area fraction two - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out [rainevap] standard_name = physics_field_for_coupling long_name = physics_field_for_coupling diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index ef0366b84..b7943725b 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -62,7 +62,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & prslp,psp,phil,qtr,prevsq,q,q1,t1,u1,v1,fscav, & & rn,kbot,ktop,kcnv,islimsk,garea, & & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, & - & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal, + & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal, & & sigmain,sigmaout,errmsg,errflg) ! use machine , only : kind_phys @@ -77,7 +77,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:), & - & qmicro(:,:),tmf(:,:),prevsq(:,:),q(:,:),sigmain(:,:) + & qmicro(:,:),tmf(:,:),prevsq(:,:),q(:,:) + + real(kind=kind_phys), intent(in) :: sigmain(:,:) ! real(kind=kind_phys), dimension(:), intent(in) :: fscav integer, intent(inout) :: kcnv(:) @@ -164,8 +166,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys) omega_u(im,km),zdqca(im,km),qlks(im,km), & omegac(im),zeta(im,km),dbyo1(im,km), & sigmab(im) - logical flag_shallow - real(kind=kind_phys) gravinv + real(kind=kind_phys) gravinv,dxcrtas c physical parameters ! parameter(g=grav,asolfac=0.89) @@ -196,6 +197,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) parameter(betaw=.03,dxcrt=15.e3,dxcrtc0=9.e3) parameter(h1=0.33333333) +! progsigma + parameter(dxcrtas=30.e3) c local variables and arrays real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), & uo(im,km), vo(im,km), qeso(im,km), @@ -340,6 +343,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo endif !! + !> - Return to the calling routine if deep convection is present or the surface buoyancy flux is negative. totflg = .true. do i=1,im @@ -1932,20 +1936,20 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & c c Prognostic closure if(progsigma)then - flag_shallow = .true. - call progsigma_calc(im,km,first_time_step,restart,flag_shallow, + call progsigma_calc(im,km,first_time_step,restart, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & prevsq,q,kbcon1,ktcon,cnvflg,gdx, + & prevsq,q,kbcon1,ktcon,cnvflg, & sigmain,sigmaout,sigmab,errmsg,errflg) 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. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. + do i= 1, im if(cnvflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) - if(progsigma)then + if(progsigma .and. gdx(i) < dxcrtas)then xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) else xmb(i) = advfac(i)*betaw*rho*wc(i) From f496099a9a55acdea52e23f9c2a6d5b043f5b1df Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 19 May 2022 00:19:54 +0000 Subject: [PATCH 210/217] Fix from Joe to remove code that was added back in by the big merge. --- physics/GFS_rrtmgp_cloud_mp.F90 | 19 +++++-------------- 1 file changed, 5 insertions(+), 14 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 53b4d801c..60d5a0a85 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -179,20 +179,11 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic ! ! SGS clouds present, use cloud-fraction modified to include sgs clouds. ! - if ((imfdeepcnv==imfdeepcnv_gf .or. do_mynnedmf) .and. kdt>1) then - ! MYNN sub-grid cloud fraction. - if (do_mynnedmf) then - ! If rain/snow present, use GFDL MP cloud-fraction... - if (tracer(iCol,iLay,i_cldrain)>1.0e-7 .OR. tracer(iCol,iLay,i_cldsnow)>1.0e-7) then - cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) - endif - ! GF sub-grid cloud fraction. - else - ! If no convective cloud condensate present, use GFDL MP cloud-fraction.... - if (qci_conv(iCol,iLay) <= 0.) then - cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) - endif - endif + if (imfdeepcnv==imfdeepcnv_gf .and. kdt>1) then + ! If no convective cloud condensate present, use GFDL MP cloud-fraction.... + if (qci_conv(iCol,iLay) <= 0.) then + cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) + endif ! ! No SGS clouds, use GFDL MP cloud-fraction... ! From fc79cc39ecaef4bc567b052842dc560e3253f0d8 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Thu, 19 May 2022 19:59:43 +0000 Subject: [PATCH 211/217] Change intent to inout for conditional variables --- physics/GFS_MP_generic_post.F90 | 4 ++-- physics/GFS_MP_generic_post.meta | 4 ++-- physics/GFS_suite_interstitial_3.F90 | 4 ++-- physics/GFS_suite_interstitial_3.meta | 4 ++-- physics/satmedmfvdifq.F | 4 ++-- physics/satmedmfvdifq.meta | 2 +- 6 files changed, 11 insertions(+), 11 deletions(-) diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90 index 3cdfe91f3..992c9b969 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -81,8 +81,8 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), dimension(:), intent(inout) :: diceprv real(kind=kind_phys), dimension(:), intent(inout) :: dsnowprv real(kind=kind_phys), dimension(:), intent(inout) :: dgraupelprv - real(kind=kind_phys), dimension(:,:), intent(out) :: dqdt_qmicro - real(kind=kind_phys), dimension(:,:), intent(out) :: prevsq + real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdt_qmicro + real(kind=kind_phys), dimension(:,:), intent(inout) :: prevsq real(kind=kind_phys), intent(in) :: dtp ! CCPP error handling diff --git a/physics/GFS_MP_generic_post.meta b/physics/GFS_MP_generic_post.meta index 20881fbb3..7ba09363a 100644 --- a/physics/GFS_MP_generic_post.meta +++ b/physics/GFS_MP_generic_post.meta @@ -738,7 +738,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [prevsq] standard_name = specific_humidity_on_previous_timestep long_name = specific_humidity_on_previous_timestep @@ -746,7 +746,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [lssav] standard_name = flag_for_diagnostics long_name = logical flag for storing diagnostics diff --git a/physics/GFS_suite_interstitial_3.F90 b/physics/GFS_suite_interstitial_3.F90 index 9fa7d69b7..0f666d4a5 100644 --- a/physics/GFS_suite_interstitial_3.F90 +++ b/physics/GFS_suite_interstitial_3.F90 @@ -52,8 +52,8 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & real(kind=kind_phys), intent(in ), dimension(:,:) :: gt0 real(kind=kind_phys), intent(in ), dimension(:,:,:) :: gq0 - real(kind=kind_phys), intent(out ), dimension(:,:) :: sigmain - real(kind=kind_phys), intent(out ), dimension(:,:) :: sigmaout,qmicro + real(kind=kind_phys), intent(inout ), dimension(:,:) :: sigmain + real(kind=kind_phys), intent(inout ), dimension(:,:) :: sigmaout,qmicro real(kind=kind_phys), intent(inout), dimension(:,:) :: rhc, save_qc ! save_qi is not allocated for Zhao-Carr MP real(kind=kind_phys), intent(inout), dimension(:,:) :: save_qi diff --git a/physics/GFS_suite_interstitial_3.meta b/physics/GFS_suite_interstitial_3.meta index fbeb9f03c..fe52a1adc 100644 --- a/physics/GFS_suite_interstitial_3.meta +++ b/physics/GFS_suite_interstitial_3.meta @@ -229,7 +229,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [sigmaout] standard_name = updraft_area_fraction_updated_by_physics long_name = convective updraft area fraction updated by physics @@ -237,7 +237,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [qmicro] standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics long_name = moisture tendency due to microphysics diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index c7a6fadc9..865e4481c 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -99,7 +99,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr real(kind=kind_phys), intent(in) :: rlmx, elmx real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), & - & tdt(:,:), rtg(:,:,:) + & tdt(:,:), rtg(:,:,:), tmf(:,:) real(kind=kind_phys), intent(in) :: & & u1(:,:), v1(:,:), & & t1(:,:), q1(:,:,:), & @@ -123,7 +123,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & & dtsfc(:), dqsfc(:), & & hpbl(:) real(kind=kind_phys), intent(out) :: & - & dkt(:,:), dku(:,:), tmf(:,:) + & dkt(:,:), dku(:,:) ! logical, intent(in) :: dspheat character(len=*), intent(out) :: errmsg diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 88ab676b8..8538c6aa7 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -215,7 +215,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [u1] standard_name = x_wind long_name = x component of layer wind From 1d2d97038ecf9a0f94f235e552e516183f0cc18e Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 19 May 2022 20:56:48 +0000 Subject: [PATCH 212/217] move smoke to physics/smoke --- {smoke => physics/smoke}/dep_dry_gocart_mod.F90 | 0 {smoke => physics/smoke}/dep_dry_mod.F90 | 0 {smoke => physics/smoke}/dep_simple_mod.F90 | 0 {smoke => physics/smoke}/dep_vertmx_mod.F90 | 0 {smoke => physics/smoke}/dep_wet_ls_mod.F90 | 0 {smoke => physics/smoke}/dust_data_mod.F90 | 0 {smoke => physics/smoke}/dust_fengsha_mod.F90 | 0 {smoke => physics/smoke}/module_add_emiss_burn.F90 | 0 {smoke => physics/smoke}/module_plumerise1.F90 | 0 {smoke => physics/smoke}/module_smoke_plumerise.F90 | 0 {smoke => physics/smoke}/module_zero_plumegen_coms.F90 | 0 {smoke => physics/smoke}/plume_data_mod.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_config.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_data.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_lsdep_wrapper.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_lsdep_wrapper.meta | 0 {smoke => physics/smoke}/rrfs_smoke_postpbl.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_postpbl.meta | 0 {smoke => physics/smoke}/rrfs_smoke_wrapper.F90 | 0 {smoke => physics/smoke}/rrfs_smoke_wrapper.meta | 0 {smoke => physics/smoke}/seas_data_mod.F90 | 0 {smoke => physics/smoke}/seas_mod.F90 | 0 {smoke => physics/smoke}/seas_ngac_mod.F90 | 0 23 files changed, 0 insertions(+), 0 deletions(-) rename {smoke => physics/smoke}/dep_dry_gocart_mod.F90 (100%) rename {smoke => physics/smoke}/dep_dry_mod.F90 (100%) rename {smoke => physics/smoke}/dep_simple_mod.F90 (100%) rename {smoke => physics/smoke}/dep_vertmx_mod.F90 (100%) rename {smoke => physics/smoke}/dep_wet_ls_mod.F90 (100%) rename {smoke => physics/smoke}/dust_data_mod.F90 (100%) rename {smoke => physics/smoke}/dust_fengsha_mod.F90 (100%) rename {smoke => physics/smoke}/module_add_emiss_burn.F90 (100%) rename {smoke => physics/smoke}/module_plumerise1.F90 (100%) rename {smoke => physics/smoke}/module_smoke_plumerise.F90 (100%) rename {smoke => physics/smoke}/module_zero_plumegen_coms.F90 (100%) rename {smoke => physics/smoke}/plume_data_mod.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_config.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_data.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_lsdep_wrapper.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_lsdep_wrapper.meta (100%) rename {smoke => physics/smoke}/rrfs_smoke_postpbl.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_postpbl.meta (100%) rename {smoke => physics/smoke}/rrfs_smoke_wrapper.F90 (100%) rename {smoke => physics/smoke}/rrfs_smoke_wrapper.meta (100%) rename {smoke => physics/smoke}/seas_data_mod.F90 (100%) rename {smoke => physics/smoke}/seas_mod.F90 (100%) rename {smoke => physics/smoke}/seas_ngac_mod.F90 (100%) diff --git a/smoke/dep_dry_gocart_mod.F90 b/physics/smoke/dep_dry_gocart_mod.F90 similarity index 100% rename from smoke/dep_dry_gocart_mod.F90 rename to physics/smoke/dep_dry_gocart_mod.F90 diff --git a/smoke/dep_dry_mod.F90 b/physics/smoke/dep_dry_mod.F90 similarity index 100% rename from smoke/dep_dry_mod.F90 rename to physics/smoke/dep_dry_mod.F90 diff --git a/smoke/dep_simple_mod.F90 b/physics/smoke/dep_simple_mod.F90 similarity index 100% rename from smoke/dep_simple_mod.F90 rename to physics/smoke/dep_simple_mod.F90 diff --git a/smoke/dep_vertmx_mod.F90 b/physics/smoke/dep_vertmx_mod.F90 similarity index 100% rename from smoke/dep_vertmx_mod.F90 rename to physics/smoke/dep_vertmx_mod.F90 diff --git a/smoke/dep_wet_ls_mod.F90 b/physics/smoke/dep_wet_ls_mod.F90 similarity index 100% rename from smoke/dep_wet_ls_mod.F90 rename to physics/smoke/dep_wet_ls_mod.F90 diff --git a/smoke/dust_data_mod.F90 b/physics/smoke/dust_data_mod.F90 similarity index 100% rename from smoke/dust_data_mod.F90 rename to physics/smoke/dust_data_mod.F90 diff --git a/smoke/dust_fengsha_mod.F90 b/physics/smoke/dust_fengsha_mod.F90 similarity index 100% rename from smoke/dust_fengsha_mod.F90 rename to physics/smoke/dust_fengsha_mod.F90 diff --git a/smoke/module_add_emiss_burn.F90 b/physics/smoke/module_add_emiss_burn.F90 similarity index 100% rename from smoke/module_add_emiss_burn.F90 rename to physics/smoke/module_add_emiss_burn.F90 diff --git a/smoke/module_plumerise1.F90 b/physics/smoke/module_plumerise1.F90 similarity index 100% rename from smoke/module_plumerise1.F90 rename to physics/smoke/module_plumerise1.F90 diff --git a/smoke/module_smoke_plumerise.F90 b/physics/smoke/module_smoke_plumerise.F90 similarity index 100% rename from smoke/module_smoke_plumerise.F90 rename to physics/smoke/module_smoke_plumerise.F90 diff --git a/smoke/module_zero_plumegen_coms.F90 b/physics/smoke/module_zero_plumegen_coms.F90 similarity index 100% rename from smoke/module_zero_plumegen_coms.F90 rename to physics/smoke/module_zero_plumegen_coms.F90 diff --git a/smoke/plume_data_mod.F90 b/physics/smoke/plume_data_mod.F90 similarity index 100% rename from smoke/plume_data_mod.F90 rename to physics/smoke/plume_data_mod.F90 diff --git a/smoke/rrfs_smoke_config.F90 b/physics/smoke/rrfs_smoke_config.F90 similarity index 100% rename from smoke/rrfs_smoke_config.F90 rename to physics/smoke/rrfs_smoke_config.F90 diff --git a/smoke/rrfs_smoke_data.F90 b/physics/smoke/rrfs_smoke_data.F90 similarity index 100% rename from smoke/rrfs_smoke_data.F90 rename to physics/smoke/rrfs_smoke_data.F90 diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 similarity index 100% rename from smoke/rrfs_smoke_lsdep_wrapper.F90 rename to physics/smoke/rrfs_smoke_lsdep_wrapper.F90 diff --git a/smoke/rrfs_smoke_lsdep_wrapper.meta b/physics/smoke/rrfs_smoke_lsdep_wrapper.meta similarity index 100% rename from smoke/rrfs_smoke_lsdep_wrapper.meta rename to physics/smoke/rrfs_smoke_lsdep_wrapper.meta diff --git a/smoke/rrfs_smoke_postpbl.F90 b/physics/smoke/rrfs_smoke_postpbl.F90 similarity index 100% rename from smoke/rrfs_smoke_postpbl.F90 rename to physics/smoke/rrfs_smoke_postpbl.F90 diff --git a/smoke/rrfs_smoke_postpbl.meta b/physics/smoke/rrfs_smoke_postpbl.meta similarity index 100% rename from smoke/rrfs_smoke_postpbl.meta rename to physics/smoke/rrfs_smoke_postpbl.meta diff --git a/smoke/rrfs_smoke_wrapper.F90 b/physics/smoke/rrfs_smoke_wrapper.F90 similarity index 100% rename from smoke/rrfs_smoke_wrapper.F90 rename to physics/smoke/rrfs_smoke_wrapper.F90 diff --git a/smoke/rrfs_smoke_wrapper.meta b/physics/smoke/rrfs_smoke_wrapper.meta similarity index 100% rename from smoke/rrfs_smoke_wrapper.meta rename to physics/smoke/rrfs_smoke_wrapper.meta diff --git a/smoke/seas_data_mod.F90 b/physics/smoke/seas_data_mod.F90 similarity index 100% rename from smoke/seas_data_mod.F90 rename to physics/smoke/seas_data_mod.F90 diff --git a/smoke/seas_mod.F90 b/physics/smoke/seas_mod.F90 similarity index 100% rename from smoke/seas_mod.F90 rename to physics/smoke/seas_mod.F90 diff --git a/smoke/seas_ngac_mod.F90 b/physics/smoke/seas_ngac_mod.F90 similarity index 100% rename from smoke/seas_ngac_mod.F90 rename to physics/smoke/seas_ngac_mod.F90 From d4d0b719ab297741ea484bee00e8285cca423a64 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 24 May 2022 18:18:45 +0000 Subject: [PATCH 213/217] Simplify machine.F and remove unused types. --- physics/machine.F | 38 ++++++++++---------------------------- 1 file changed, 10 insertions(+), 28 deletions(-) diff --git a/physics/machine.F b/physics/machine.F index 9b09d235c..e9c572ef2 100644 --- a/physics/machine.F +++ b/physics/machine.F @@ -6,42 +6,24 @@ module machine implicit none -#ifndef SINGLE_PREC integer, parameter :: kind_io4 = 4, kind_io8 = 8 , kind_ior = 8 & &, kind_evod = 8, kind_dbl_prec = 8 & &, kind_sngl_prec = 4 -# ifdef __PGI - &, kind_qdt_prec = 8 & -# else - &, kind_qdt_prec = 16 & -# endif - &, kind_rad = 8 & - &, kind_phys = 8 ,kind_taum=8 & - &, kind_grid = 8 & - &, kind_REAL = 8 &! used in cmp_comm - &, kind_LOGICAL = 4 & - &, kind_INTEGER = 4 ! -,,- +#ifdef SINGLE_PREC + integer, parameter :: kind_rad = kind_sngl_prec & + &, kind_phys = kind_sngl_prec & + &, kind_grid = kind_dbl_prec &! atmos_cubed_sphere requres kind_grid=8 + &, kind_REAL = kind_sngl_prec ! used in cmp_comm #else - integer, parameter :: kind_io4 = 4, kind_io8 = 8 , kind_ior = 8 & - &, kind_evod = 4, kind_dbl_prec = 8 & - &, kind_sngl_prec = 4 -# ifdef __PGI - &, kind_qdt_prec = 8 & -# else - &, kind_qdt_prec = 16 & -# endif - &, kind_rad = 4 & - &, kind_phys = 4 ,kind_taum=4 & - &, kind_grid = 8 &! atmos_cubed_sphere requres kind_grid=8 - &, kind_REAL = 4 &! used in cmp_comm - &, kind_LOGICAL = 4 & - &, kind_INTEGER = 4 ! -,,- - + integer, parameter :: kind_rad = kind_dbl_prec & + &, kind_phys = kind_dbl_prec & + &, kind_grid = kind_dbl_prec &! atmos_cubed_sphere requres kind_grid=8 + &, kind_REAL = kind_dbl_prec ! used in cmp_comm #endif #ifdef OVERLOAD_R4 - integer, parameter :: kind_dyn = 4 + integer, parameter :: kind_dyn = 4 #else integer, parameter :: kind_dyn = 8 #endif From 942f9adcef364f463158c7e7a097a97b4ddb76f7 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 25 May 2022 22:08:44 +0000 Subject: [PATCH 214/217] correct bug in machine.F --- physics/machine.F | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/physics/machine.F b/physics/machine.F index e9c572ef2..eb1dcd257 100644 --- a/physics/machine.F +++ b/physics/machine.F @@ -8,7 +8,8 @@ module machine integer, parameter :: kind_io4 = 4, kind_io8 = 8 , kind_ior = 8 & &, kind_evod = 8, kind_dbl_prec = 8 & - &, kind_sngl_prec = 4 + &, kind_sngl_prec = 4, kind_INTEGER = 4 & + &, kind_LOGICAL = 4 #ifdef SINGLE_PREC integer, parameter :: kind_rad = kind_sngl_prec & From 42184e7d30cef3553508e147a4b9017c41454c1f Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Thu, 9 Jun 2022 19:14:22 +0000 Subject: [PATCH 215/217] bugfix for converting abs temp to theta --- physics/module_sf_mynn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 98e894155..0d81e145a 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -848,7 +848,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & DO I=its,ite ! CONVERT LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: - TH1D(I)=T1D(I)**(100000./P1D(I))**ROVCP !(Theta, K) + TH1D(I)=T1D(I)*(100000./P1D(I))**ROVCP !(Theta, K) TC1D(I)=T1D(I)-273.15 !(T, Celsius) ENDDO From 600991e94d80e02f826068fb733b8dca3835f59b Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 15 Jun 2022 14:42:51 +0000 Subject: [PATCH 216/217] changes to get this to compile --- physics/lsm_ruc.F90 | 4 ++-- physics/mynnedmf_wrapper.F90 | 16 ++-------------- 2 files changed, 4 insertions(+), 16 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index dd3bf19ef..d206308cb 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -324,8 +324,8 @@ subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & & imp_physics_nssl, & - & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, zs,& - & t1, q1, qc, stype, vtype, sigmaf, laixy, & + & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, & + & oro, sigma, zs, t1, q1, qc, stype, vtype, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & & rainnc, rainc, ice, snow, graupel, prsl1, zf, & & wind, shdmin, shdmax, & diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 98909be2d..5917145fe 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -183,11 +183,8 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, intent(in) :: cplflx !smoke/chem - !logical, intent(in) :: mix_chem, fire_turb - !integer, intent(in) :: nchem, ndvel, kdvel - !for testing only: - logical, parameter :: mix_chem=.false., fire_turb=.false. - integer, parameter :: nchem=2, ndvel=2, kdvel=1 + integer, intent(in) :: nchem, ndvel + integer, parameter :: kdvel=1 ! NAMELIST OPTIONS (INPUT): logical, intent(in) :: & @@ -364,15 +361,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !initialize arrays for test EMIS_ANT_NO = 0. vdep = 0. ! hli for chem dry deposition, 0 temporarily - if (mix_chem) then - allocate ( chem3d(im,levs,nchem) ) - do k=1,levs - do i=1,im - chem3d(i,k,1)=qgrs_smoke_conc(i,k) - chem3d(i,k,2)=qgrs_dust_conc (i,k) - enddo - enddo - endif ! Check incoming moist species to ensure non-negative values ! First, create height (dz) and pressure differences (delp) From fd991180a32ba51076fbe196f5630d3bddb5b3fd Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 21 Jun 2022 12:07:29 +0000 Subject: [PATCH 217/217] Remove unneeded code --- physics/module_sf_mynn.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 6a9bb909f..0d81e145a 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -111,10 +111,6 @@ MODULE module_sf_mynn INTEGER, PARAMETER :: debug_code = 0 !0: no extra ouput !1: check input !2: everything - heavy I/O - LOGICAL, PARAMETER :: compute_diag = .false. - LOGICAL, PARAMETER :: compute_flux = .true. !shouldn't need compute - ! these in FV3. They will be written over anyway. - ! Computing the fluxes here is leftover from the WRF world. REAL, DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, & psih_stab,psih_unstab