From 99e30437b7276246c151f6cf47497a317b11a959 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 31 Mar 2021 20:59:17 -0500 Subject: [PATCH 001/212] - 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/212] - 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/212] 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/212] - 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/212] 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/212] 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/212] 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/212] 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/212] 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/212] - 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/212] 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/212] 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/212] 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/212] 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/212] 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/212] 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/212] 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/212] - 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/212] 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/212] 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/212] 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/212] 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/212] 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/212] 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/212] 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 eff984d6257f0a99855578a2ff50081e80324188 Mon Sep 17 00:00:00 2001 From: grantfirl Date: Mon, 25 Oct 2021 17:44:06 -0600 Subject: [PATCH 026/212] change flag_for_restart to do_lsm_cold_start in GFS_phys_time_vary and sfc_drv_ruc --- physics/GFS_phys_time_vary.fv3.F90 | 6 +++--- physics/GFS_phys_time_vary.fv3.meta | 6 +++--- physics/GFS_phys_time_vary.scm.F90 | 6 +++--- physics/GFS_phys_time_vary.scm.meta | 6 +++--- physics/module_sf_ruclsm.F90 | 8 ++++---- physics/sfc_drv_ruc.F90 | 32 ++++++++++++++--------------- physics/sfc_drv_ruc.meta | 12 +++++------ 7 files changed, 38 insertions(+), 38 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index a8ecc1a5e..641e3b897 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -79,14 +79,14 @@ subroutine GFS_phys_time_vary_init ( albdnir_ice, albivis_ice, albinir_ice, emiss_lnd, emiss_ice, taussxy, waxy, wtxy, & zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & - slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, flag_restart, nthrds, & + slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, lsm_cold_start, nthrds, & errmsg, errflg) implicit none ! Interface variables integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny - logical, intent(in) :: h2o_phys, iaerclm, flag_restart + logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: xlat_d(:), xlon_d(:) @@ -394,7 +394,7 @@ subroutine GFS_phys_time_vary_init ( !--- For Noah MP or RUC LSMs: initialize four components of albedo for !--- land and ice - not for restart runs - lsm_init: if (.not.flag_restart) then + lsm_init: if (lsm_cold_start) then if (lsm == lsm_noahmp .or. lsm == lsm_ruc) then if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: initialize albedo for land and ice' do ix=1,im diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 979200a85..8254923c8 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -978,9 +978,9 @@ kind = kind_phys intent = in optional = F -[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 diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index b06e46cdc..26766d397 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -73,14 +73,14 @@ subroutine GFS_phys_time_vary_init ( albdnir_ice, albivis_ice, albinir_ice, emiss_lnd, emiss_ice, taussxy, waxy, wtxy, & zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & - slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, flag_restart, nthrds, & + slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, lsm_cold_start, nthrds, & errmsg, errflg) implicit none ! Interface variables integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny - logical, intent(in) :: h2o_phys, iaerclm, flag_restart + logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: xlat_d(:), xlon_d(:) @@ -349,7 +349,7 @@ subroutine GFS_phys_time_vary_init ( !--- For Noah MP or RUC LSMs: initialize four components of albedo for !--- land and ice - not for restart runs - lsm_init: if (.not.flag_restart) then + lsm_init: if (lsm_cold_start) then if (lsm == lsm_noahmp .or. lsm == lsm_ruc) then if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: initialize albedo for land and ice' do ix=1,im diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta index a075e8d82..622df26fd 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/GFS_phys_time_vary.scm.meta @@ -978,9 +978,9 @@ kind = kind_phys intent = in optional = F -[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 diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 1e0ec2fe2..e9fd87595 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -60,7 +60,7 @@ MODULE module_sf_ruclsm !>\section gen_lsmruc GSD RUC LSM General Algorithm !! @{ SUBROUTINE LSMRUC( & - DT,init,restart,KTAU,iter,NSL, & + DT,init,lsm_cold_start,KTAU,iter,NSL, & graupelncv,snowncv,rainncv,raincv, & ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & rhosnf,precipfr, & @@ -97,7 +97,7 @@ SUBROUTINE LSMRUC( & !----------------------------------------------------------------- !-- DT time step (second) ! init - flag for initialization -! restart - flag for restart run +!lsm_cold_start - flag for cold start run ! ktau - number of time step ! NSL - number of soil layers ! NZS - number of levels in soil @@ -166,7 +166,7 @@ SUBROUTINE LSMRUC( & ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) REAL, INTENT(IN ) :: DT - LOGICAL, INTENT(IN ) :: myj,frpcpn,init,restart + LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start INTEGER, INTENT(IN ) :: NLCAT, NSCAT ! , mosaic_lu, mosaic_soil INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & ims,ime, jms,jme, kms,kme, & @@ -423,7 +423,7 @@ SUBROUTINE LSMRUC( & !> - Initialize soil/vegetation parameters !--- This is temporary until SI is added to mass coordinate ---!!!!! - if(init .and. (.not. restart) .and. iter == 1) then + if(init .and. (lsm_cold_start) .and. iter == 1) then DO J=jts,jte DO i=its,ite ! do k=1,nsl diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index e426424a8..4133f1051 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -31,7 +31,7 @@ module lsm_ruc !! \htmlinclude lsm_ruc_init.html !! subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & - flag_restart, flag_init, con_fvirt, con_rd, & + lsm_cold_start, flag_init, con_fvirt, con_rd, & im, lsoil_ruc, lsoil, kice, nlev, & ! in lsm_ruc, lsm, slmsk, stype, vtype, & ! in q1, prsl1, tsfc_lnd, tsfc_ice, tsfc_wat, & ! in @@ -49,7 +49,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & implicit none ! --- in integer, intent(in) :: me, master, isot, ivegsrc, nlunit - logical, intent(in) :: flag_restart + logical, intent(in) :: lsm_cold_start logical, intent(in) :: flag_init integer, intent(in) :: im integer, intent(in) :: lsoil_ruc @@ -154,7 +154,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & write (0,*) 'tg3=',tg3(ipr) write (0,*) 'slmsk=',slmsk(ipr) write (0,*) 'flag_init =',flag_init - write (0,*) 'flag_restart =',flag_restart + write (0,*) 'lsm_cold_start =',lsm_cold_start endif !--- initialize soil vegetation @@ -168,7 +168,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & !-- initialize background emissivity semisbase(i) = lemitbl(vtype(i)) ! no snow effect - if (.not.flag_restart) then + if (lsm_cold_start) then !-- land semis_lnd(i) = semisbase(i) * (1.-sncovr_lnd(i)) & + 0.99 * sncovr_lnd(i) @@ -195,13 +195,13 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & sfcqv_lnd(i) = q0 qs1 = rslf(prsl1(i),tsfc_ice(i)) sfcqv_ice(i) = qs1 - endif ! .not. restart + endif ! lsm_cold_start enddo ! i call init_soil_depth_3 ( zs , dzs , lsoil_ruc ) - call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in + call rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, nlev, & ! in me, master, lsm_ruc, lsm, slmsk, & ! in stype, vtype, & ! in tsfc_lnd, tsfc_wat, tg3, & ! in @@ -356,7 +356,7 @@ subroutine lsm_ruc_run & ! inputs & rhosnf, sbsno, & & cmm_lnd, chh_lnd, cmm_ice, chh_ice, & ! - & flag_iter, flag_guess, flag_init, flag_restart, & + & flag_iter, flag_guess, flag_init, lsm_cold_start, & & flag_cice, frac_grid, errmsg, errflg & & ) @@ -438,7 +438,7 @@ subroutine lsm_ruc_run & ! inputs & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice - logical, intent(in) :: flag_init, flag_restart + logical, intent(in) :: flag_init, lsm_cold_start character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -574,7 +574,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'vtype=',ipr,vtype(ipr) write (0,*)'kdt, iter =',kdt,iter write (0,*)'flag_init =',flag_init - write (0,*)'flag_restart =',flag_restart + write (0,*)'lsm_cold_start =',lsm_cold_start endif ims = 1 @@ -1037,7 +1037,7 @@ subroutine lsm_ruc_run & ! inputs !> - Call RUC LSM lsmruc() for land. call lsmruc( & - & delt, flag_init, flag_restart, kdt, iter, nsoil, & + & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_lnd(i,j), snowh_lnd(i,j), & & sncovr_lnd(i,j), & @@ -1278,7 +1278,7 @@ subroutine lsm_ruc_run & ! inputs !> - Call RUC LSM lsmruc() for ice. call lsmruc( & - & delt, flag_init, flag_restart, kdt, iter, nsoil, & + & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_ice(i,j), snowh_ice(i,j), & & sncovr_ice(i,j), & @@ -1461,8 +1461,8 @@ end subroutine lsm_ruc_run !>\ingroup lsm_ruc_group !! This subroutine contains RUC LSM initialization. - subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in - me, master, lsm_ruc, lsm, slmsk, & ! in + subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in + nlev, me, master, lsm_ruc, lsm, slmsk, & ! in stype, vtype, & ! in tskin_lnd, tskin_wat, tg3, & ! !in zs, dzs, smc, slc, stc, & ! in @@ -1471,7 +1471,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in implicit none - logical, intent(in ) :: restart + logical, intent(in ) :: lsm_cold_start integer, intent(in ) :: lsm integer, intent(in ) :: lsm_ruc integer, intent(in ) :: im, nlev @@ -1551,7 +1551,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in else if (debug_print) then write (0,*) 'Start of RUC LSM initialization' write (0,*)'lsoil, lsoil_ruc =',lsoil, lsoil_ruc - write (0,*)'restart = ',restart + write (0,*)'lsm_cold_start = ',lsm_cold_start endif ipr = 10 @@ -1579,7 +1579,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in !! Check if RUC soil data (tslb, ...) is provided or not !if (minval(tslb)==maxval(tslb)) then ! For restart runs, can assume that RUC soil data is provided - if (.not.restart) then + if (lsm_cold_start) then flag_sst = 0 diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index c793b5b9a..7fb6924bb 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -47,9 +47,9 @@ type = integer intent = in optional = F -[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 @@ -1763,9 +1763,9 @@ type = logical intent = in optional = F -[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 From da10201f6ba0bf9b9bf3dc85467c49526b3f758d Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Tue, 9 Nov 2021 21:49:55 -0600 Subject: [PATCH 027/212] 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 b99666221163823d433e9b05677e0c77cb5f9140 Mon Sep 17 00:00:00 2001 From: Laurie Carson Date: Thu, 11 Nov 2021 09:33:48 -0700 Subject: [PATCH 028/212] Add SPP option to several physics parameterizations --- physics/GFS_rrtmg_pre.F90 | 26 ++++++++++++++++- physics/GFS_rrtmg_pre.meta | 17 +++++++++++ physics/drag_suite.F90 | 23 ++++++++++++++- physics/drag_suite.meta | 17 +++++++++++ physics/module_MYNNPBL_wrapper.F90 | 20 ++++++++----- physics/module_MYNNPBL_wrapper.meta | 17 +++++++++++ physics/module_MYNNSFC_wrapper.F90 | 16 ++++++---- physics/module_MYNNSFC_wrapper.meta | 17 +++++++++++ physics/mp_thompson.F90 | 45 +++++++++++++++++++---------- physics/mp_thompson.meta | 17 +++++++++++ physics/unified_ugwp.F90 | 8 +++-- physics/unified_ugwp.meta | 17 +++++++++++ 12 files changed, 209 insertions(+), 31 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index dbea66985..8bb4f2073 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -35,7 +35,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, spp_wts_rad, do_spp, errmsg, errflg) use machine, only: kind_phys @@ -102,6 +102,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & uni_cld, effr_in, do_mynnedmf, & lmfshal, lmfdeep2, pert_clds + logical, optional, intent(in) :: do_spp + 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 @@ -1086,6 +1089,27 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo +! --- add spp + if ( do_spp .ne. 0 ) then + + do k=1,lm + if (k < levs) then + do i=1,im + effrl_inout(i,k) = effrl_inout(i,k) - spp_wts_rad(i,k) * effrl_inout(i,k) + effri_inout(i,k) = effri_inout(i,k) - spp_wts_rad(i,k) * effri_inout(i,k) + effrs_inout(i,k) = effrs_inout(i,k) - spp_wts_rad(i,k) * effrs_inout(i,k) + enddo + else + do i=1,im + effrl_inout(i,k) = effrl_inout(i,k) - spp_wts_rad(i,levs) * effrl_inout(i,k) + effri_inout(i,k) = effri_inout(i,k) - spp_wts_rad(i,levs) * effri_inout(i,k) + effrs_inout(i,k) = effrs_inout(i,k) - spp_wts_rad(i,levs) * effrs_inout(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 48ddc586d..247cad3b5 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1169,6 +1169,23 @@ kind = kind_phys intent = out optional = F +[spp_wts_rad] + standard_name = weights_for_stochastic_spp_rad_perturbation + long_name = weights for stochastic spp rad perturbation + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[do_spp] + standard_name = flag_for_stochastic_spp_option + long_name = flag for stochastic spp option + units = flag + dimensions = () + 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/drag_suite.F90 b/physics/drag_suite.F90 index 9b110d689..cf5fb6616 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -218,7 +218,8 @@ subroutine drag_suite_run( & & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & & dtend, dtidx, index_of_process_orographic_gwd, & & index_of_temperature, index_of_x_wind, & - & index_of_y_wind, ldiag3d, errmsg, errflg) + & index_of_y_wind, ldiag3d, & + & spp_wts_gwd, do_spp, errmsg, errflg) ! ******************************************************************** ! -----> I M P L E M E N T A T I O N V E R S I O N <---------- @@ -365,6 +366,11 @@ subroutine drag_suite_run( & real(kind=kind_phys), dimension(im,km) :: zl ! = PHIL/g !SPP + real(kind=kind_phys), dimension(im) :: var_stoch, varss_stoch, & + varmax_ss_stoch, varmax_fd_stoch + real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) + logical, intent(in) :: do_spp + real(kind=kind_phys), dimension(im) :: rstoch !Output: @@ -602,6 +608,21 @@ subroutine drag_suite_run( & end if ! if (me==master) print *,"in Drag Suite, ss_taper:",ss_taper +! SPP, if do_spp is false, no perturbations are applied. +if ( do_spp ) then + do i = its,im + var_stoch(i) = var(i) + var(i)*0.75*spp_wts_gwd(i,1) + varss_stoch(i) = varss(i) + varss(i)*0.75*spp_wts_gwd(i,1) + varmax_ss_stoch(i) = varmax_ss + varmax_ss*0.75*spp_wts_gwd(i,1) + varmax_fd_stoch(i) = varmax_fd + varmax_fd*0.75*spp_wts_gwd(i,1) + enddo +else + var_stoch = var + varss_stoch = varss + varmax_ss_stoch = varmax_ss + varmax_fd_stoch = varmax_fd +endif + !--- calculate length of grid for flow-blocking drag ! delx = dx(1) diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index a36fc1e82..acb9fe9a2 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -703,6 +703,23 @@ type = logical intent = in optional = F +[spp_wts_gwd] + standard_name = weights_for_stochastic_spp_gwd_perturbation + long_name = weights for stochastic spp gwd perturbation + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[do_spp] + standard_name = flag_for_stochastic_spp_option + long_name = flag for stochastic spp option + units = flag + dimensions = () + 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/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 4b034f588..32cf6044d 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -108,7 +108,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & ltaerosol, lprnt, errmsg, errflg ) + & ltaerosol, spp_wts_pbl, do_spp, lprnt, errmsg, errflg ) ! should be moved to inside the mynn: use machine , only : kind_phys @@ -195,6 +195,7 @@ SUBROUTINE mynnedmf_wrapper_run( & ! NAMELIST OPTIONS (INPUT): LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect, ltaerosol, & lprnt, do_mynnsfclay, & + do_spp, & flag_for_pbl_generic_tend INTEGER, INTENT(IN) :: & & bl_mynn_cloudpdf, & @@ -221,7 +222,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !MISC CONFIGURATION OPTIONS INTEGER, PARAMETER :: & - & spp_pbl=0, & & bl_mynn_mixscalars=1, & & levflag=2 LOGICAL :: & @@ -231,7 +231,8 @@ SUBROUTINE mynnedmf_wrapper_run( & LOGICAL, PARAMETER :: cycling = .false. INTEGER, PARAMETER :: param_first_scalar = 1 INTEGER :: & - & p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni + & spp_pbl, & + & p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni !MYNN-1D REAL(kind=kind_phys), intent(in) :: delt, dtf @@ -275,6 +276,9 @@ SUBROUTINE mynnedmf_wrapper_run( & & Tsq, Qsq, Cov, exch_h, exch_m real(kind=kind_phys), dimension(:), intent(in) :: xmu real(kind=kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw + ! spp_wts_pbl only allocated if do_spp == .true. + real(kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl + !LOCAL real(kind=kind_phys), dimension(im,levs) :: & & sqv,sqc,sqi,qnc,qni,ozone,qnwfa,qnifa, & @@ -282,8 +286,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & RUBLTEN, RVBLTEN, RTHBLTEN, RQVBLTEN, & & RQCBLTEN, RQNCBLTEN, RQIBLTEN, RQNIBLTEN, & & RQNWFABLTEN, RQNIFABLTEN, & - & dqke,qWT,qSHEAR,qBUOY,qDISS, & - & pattern_spp_pbl + & dqke,qWT,qSHEAR,qBUOY,qDISS real(kind=kind_phys), allocatable :: old_ozone(:,:) !MYNN-CHEM arrays @@ -525,9 +528,12 @@ SUBROUTINE mynnedmf_wrapper_run( & ! qi(i,k)=qi(i,k)/(1.0 - qvsh(i,k)) rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)) w(i,k) = -omega(i,k)/(rho(i,k)*g) - pattern_spp_pbl(i,k)=0.0 enddo enddo + if ( do_spp ) then + spp_pbl=1 + endif + do i=1,im if (slmsk(i)==1. .or. slmsk(i)==2.) then !sea/land/ice mask (=0/1/2) in FV3 xland(i)=1.0 !but land/water = (1/2) in SFCLAY_mynn @@ -708,7 +714,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & ,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=pattern_spp_pbl & !input + & ,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 diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index e88975aff..04d3fdec6 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1427,6 +1427,23 @@ type = logical intent = in optional = F +[spp_wts_pbl] + standard_name = weights_for_stochastic_spp_pbl_perturbation + long_name = weights for stochastic spp pbl perturbation + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[do_spp] + standard_name = flag_for_stochastic_spp_option + long_name = flag for stochastic spp option + units = flag + dimensions = () + type = logical + intent = in + optional = F [lprnt] standard_name = flag_print long_name = control flag for diagnostic print out diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index 271ca5a24..ac060a783 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -88,6 +88,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & FLHC, FLQC, & & U10, V10, TH2, T2, Q2, & & wstar, CHS2, CQS2, & + & spp_wts_sfc, do_spp, & ! & CP, G, ROVCP, R, XLV, & ! & SVP1, SVP2, SVP3, SVPT0, & ! & EP1,EP2,KARMAN, & @@ -134,7 +135,6 @@ SUBROUTINE mynnsfc_wrapper_run( & !MISC CONFIGURATION OPTIONS INTEGER, PARAMETER :: & - & spp_pbl = 0, & & isftcflx = 0, & !control: 0 & iz0tlnd = 0, & !control: 0 & isfflx = 1 @@ -145,12 +145,15 @@ SUBROUTINE mynnsfc_wrapper_run( & 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) + logical, intent(in) :: do_spp ! flag for using SPP perturbations + real(kind=kind_phys), intent(in) :: delt !Input data integer, dimension(:), intent(in) :: vegtype real(kind=kind_phys), dimension(:), intent(in) :: & & sigmaf,shdmax,z0pert,ztpert + real(kind_phys), dimension(:,:), intent(in) :: spp_wts_sfc real(kind=kind_phys), dimension(:,:), & & intent(in) :: phii @@ -197,10 +200,10 @@ SUBROUTINE mynnsfc_wrapper_run( & & cpm, qgh, qfx, qsfc_ruc, snowh_wat real(kind=kind_phys), dimension(im,levs) :: & - & pattern_spp_pbl, dz, th, qv + & dz, th, qv !MYNN-1D - INTEGER :: k, i + INTEGER :: k, i, spp_sfc INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE, & & IMS,IME,JMS,JME,KMS,KME, & & ITS,ITE,JTS,JTE,KTS,KTE @@ -224,9 +227,12 @@ SUBROUTINE mynnsfc_wrapper_run( & th(i,k)=t3d(i,k)/exner(i,k) !qc(i,k)=MAX(qgrs(i,k,ntcw),0.0) qv(i,k)=qvsh(i,k)/(1.0 - qvsh(i,k)) - pattern_spp_pbl(i,k)=0.0 enddo enddo + if ( do_spp ) then + spp_sfc=1 + endif + do i=1,im if (slmsk(i)==1. .or. slmsk(i)==2.)then !sea/land/ice mask (=0/1/2) in FV3 xland(i)=1.0 !but land/water = (1/2) in SFCLAY_mynn @@ -321,7 +327,7 @@ SUBROUTINE mynnsfc_wrapper_run( & QGH=qgh,QSFC=qsfc,QSFC_RUC=qsfc_ruc, & U10=u10,V10=v10,TH2=th2,T2=t2,Q2=q2, & GZ1OZ0=GZ1OZ0,WSPD=wspd,wstar=wstar, & - spp_pbl=spp_pbl,pattern_spp_pbl=pattern_spp_pbl, & + spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_sfc, & ids=1,ide=im, jds=1,jde=1, kds=1,kde=levs, & ims=1,ime=im, jms=1,jme=1, kms=1,kme=levs, & its=1,ite=im, jts=1,jte=1, kts=1,kte=levs ) diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index b91a026e3..d3471be4f 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -931,6 +931,23 @@ kind = kind_phys intent = inout optional = F +[spp_wts_sfc] + standard_name = weights_for_stochastic_spp_sfc_perturbation + long_name = weights for stochastic spp sfc perturbation + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[do_spp] + standard_name = flag_for_stochastic_spp_option + long_name = flag for stochastic spp option + units = flag + dimensions = () + type = logical + intent = in + optional = F [lprnt] standard_name = flag_print long_name = control flag for diagnostic print out diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index c31d90b09..f43cfd6ae 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -341,6 +341,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & re_cloud, re_ice, re_snow, & mpicomm, mpirank, mpiroot, blkno, & ext_diag, diag3d, reset_diag3d, & + spp_wts_mp, do_spp, & errmsg, errflg) implicit none @@ -436,12 +437,23 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer :: has_reqc integer :: has_reqi integer :: has_reqs - ! DH* 2020-06-05 hardcode these values for not using random perturbations, - ! hasn't been tested yet with this version of module_mp_thompson.F90 - integer, parameter :: rand_perturb_on = 0 integer, parameter :: kme_stoch = 1 - !real(kind_phys) :: rand_pert(1:ncol,1:kme_stoch) - ! *DH 2020-06-05 + logical, intent(in ) :: do_spp + real(kind_phys), intent(in) :: spp_wts_mp(:,:) + !+---+-----------------------------------------------------------------+ + !gthompsn 21Mar2018 + ! Setting spp_mp to 1 gives graupel Y-intercept pertubations (2^0) + ! 2 gives cloud water distribution gamma shape parameter + ! perturbations (2^1) + ! 4 gives CCN & IN activation perturbations (2^2) + ! 3 gives both 1+2 + ! 5 gives both 1+4 + ! 6 gives both 2+4 + ! 7 gives all 1+2+4 + ! For now (22Mar2018), standard deviation should be only 0.25 and cut-off at 1.5 + ! in order to constrain the various perturbations from being too extreme. + !+---+-----------------------------------------------------------------+ + integer :: spp_mp ! Dimensions used in mp_gt_driver integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -499,6 +511,13 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & return end if + ! Set stochastic physics selection to apply all perturbations + if ( do_spp ) then + spp_mp=7 + else + spp_mp=0 + endif + ! Set reduced time step if subcycling is used if (nsteps>1) then dtstep = dtp/real(nsteps, kind=kind_phys) @@ -683,10 +702,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & re_cloud=re_cloud, re_ice=re_ice, re_snow=re_snow, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & - rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & - ! DH* 2020-06-05 not passing this optional argument, see - ! comment in module_mp_thompson.F90 / mp_gt_driver - !rand_pert=rand_pert, & + rand_perturb_on=spp_mp, kme_stoch=kme_stoch, & + rand_pert=spp_wts_mp, & 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, & @@ -722,10 +739,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & refl_10cm=refl_10cm, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & - rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & - ! DH* 2020-06-05 not passing this optional argument, see - ! comment in module_mp_thompson.F90 / mp_gt_driver - !rand_pert=rand_pert, & + rand_perturb_on=spp_mp, kme_stoch=kme_stoch, & + rand_pert=spp_wts_mp, & 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, & @@ -763,7 +778,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & re_cloud=re_cloud, re_ice=re_ice, re_snow=re_snow, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & - rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & + rand_perturb_on=spp_mp, kme_stoch=kme_stoch, & ! DH* 2020-06-05 not passing this optional argument, see ! comment in module_mp_thompson.F90 / mp_gt_driver !rand_pert=rand_pert, & @@ -801,7 +816,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & refl_10cm=refl_10cm, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & - rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & + rand_perturb_on=spp_mp, kme_stoch=kme_stoch, & ! DH* 2020-06-05 not passing this optional argument, see ! comment in module_mp_thompson.F90 / mp_gt_driver !rand_pert=rand_pert, & diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index ab00e6524..ec7d30af5 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -758,6 +758,23 @@ type = logical intent = in optional = F +[spp_wts_mp] + standard_name = weights_for_stochastic_spp_mp_perturbation + long_name = weights for stochastic spp mp perturbation + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[do_spp] + standard_name = flag_for_stochastic_spp_option + long_name = flag for stochastic spp option + units = flag + dimensions = () + 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/unified_ugwp.F90 b/physics/unified_ugwp.F90 index da79ecde8..491a4168c 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -218,7 +218,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, index_of_process_orographic_gwd, index_of_process_nonorographic_gwd, & ldiag3d, lssav, flag_for_gwd_generic_tend, do_ugwp_v0, do_ugwp_v0_orog_only, & do_ugwp_v0_nst_only, do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & - gwd_opt, errmsg, errflg) + gwd_opt, spp_wts_gwd, do_spp, errmsg, errflg) implicit none @@ -296,6 +296,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, do_gsl_drag_ls_bl, do_gsl_drag_ss, & do_gsl_drag_tofd + real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) + logical, intent(in) :: do_spp + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -343,7 +346,8 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & dtend, dtidx, index_of_process_orographic_gwd, & index_of_temperature, index_of_x_wind, & - index_of_y_wind, ldiag3d, errmsg, errflg) + index_of_y_wind, ldiag3d, spp_wts_gwd,do_spp, & + errmsg, errflg) ! ! put zeros due to xy GSL-drag style: dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls ! diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index b2f35e45f..2857d7012 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -1330,6 +1330,23 @@ type = integer intent = in optional = F +[spp_wts_gwd] + standard_name = weights_for_stochastic_spp_gwd_perturbation + long_name = weights for stochastic spp gwd perturbation + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[do_spp] + standard_name = flag_for_stochastic_spp_option + long_name = flag for stochastic spp option + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 094737206c34ed5462c155e482eed13a46ca1eac Mon Sep 17 00:00:00 2001 From: Laurie Carson Date: Mon, 22 Nov 2021 09:34:50 -0700 Subject: [PATCH 029/212] bug fixes --- physics/module_MYNNSFC_wrapper.F90 | 2 +- physics/module_mp_thompson.F90 | 18 ++++-------------- physics/mp_thompson.F90 | 8 ++------ 3 files changed, 7 insertions(+), 21 deletions(-) diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index ac060a783..d8c6bd38b 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -327,7 +327,7 @@ SUBROUTINE mynnsfc_wrapper_run( & QGH=qgh,QSFC=qsfc,QSFC_RUC=qsfc_ruc, & U10=u10,V10=v10,TH2=th2,T2=t2,Q2=q2, & GZ1OZ0=GZ1OZ0,WSPD=wspd,wstar=wstar, & - spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_sfc, & + spp_pbl=spp_sfc,pattern_spp_pbl=spp_wts_sfc, & ids=1,ide=im, jds=1,jde=1, kds=1,kde=levs, & ims=1,ime=im, jms=1,jme=1, kms=1,kme=levs, & its=1,ite=im, jts=1,jte=1, kts=1,kte=levs ) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index f05aa8ba2..90b70a66f 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1119,23 +1119,13 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! No need to test for every subcycling step test_only_once: if (first_time_step .and. istep==1) then - ! DH* 2020-06-05: The stochastic perturbations code was retrofitted - ! from a newer version of the Thompson MP scheme, but it has not been - ! tested yet. - if (rand_perturb_on .ne. 0) then - errmsg = 'Logic error in mp_gt_driver: the stochastic perturbations code ' // & - 'has not been tested yet with this version of the Thompson scheme' + ! Activate this code when removing the guard above + if (rand_perturb_on .ne. 0 .and. .not. present(rand_pert)) then + errmsg = 'Logic error in mp_gt_driver: random perturbations are on, ' // & + 'but optional argument rand_pert is not present' errflg = 1 return end if - ! Activate this code when removing the guard above - !if (rand_perturb_on .ne. 0 .and. .not. present(rand_pert)) then - ! errmsg = 'Logic error in mp_gt_driver: random perturbations are on, ' // & - ! 'but optional argument rand_pert is not present' - ! errflg = 1 - ! return - !end if - ! *DH 2020-06-05 if ( (present(tt) .and. (present(th) .or. present(pii))) .or. & (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index f43cfd6ae..5ae812d32 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -779,9 +779,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & re_cloud=re_cloud, re_ice=re_ice, re_snow=re_snow, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & rand_perturb_on=spp_mp, kme_stoch=kme_stoch, & - ! DH* 2020-06-05 not passing this optional argument, see - ! comment in module_mp_thompson.F90 / mp_gt_driver - !rand_pert=rand_pert, & + rand_pert=spp_wts_mp, & 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, & @@ -817,9 +815,7 @@ 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, kme_stoch=kme_stoch, & - ! DH* 2020-06-05 not passing this optional argument, see - ! comment in module_mp_thompson.F90 / mp_gt_driver - !rand_pert=rand_pert, & + rand_pert=spp_wts_mp, & 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 1337aeb68955a3e1346a80f3f2cb230f7eabd89a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 23 Nov 2021 10:02:33 -0700 Subject: [PATCH 030/212] Fix dimensions of vertical eta level variables in several metadata files --- physics/GFS_rrtmg_setup.meta | 2 +- physics/GFS_rrtmgp_setup.meta | 2 +- physics/GFS_stochastics.meta | 2 +- physics/cires_ugwp.meta | 4 ++-- physics/ugwpv1_gsldrag.meta | 4 ++-- physics/unified_ugwp.meta | 4 ++-- 6 files changed, 9 insertions(+), 9 deletions(-) diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index ecd849c48..d80faf8a5 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -12,7 +12,7 @@ standard_name = sigma_pressure_hybrid_vertical_coordinate long_name = vertical sigma coordinate for radiation initialization units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index 4043392a9..ab9b0a49c 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -76,7 +76,7 @@ standard_name = sigma_pressure_hybrid_vertical_coordinate long_name = vertical sigma coordinate for radiation initialization units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in diff --git a/physics/GFS_stochastics.meta b/physics/GFS_stochastics.meta index 0b2c1da2f..c78dbe015 100644 --- a/physics/GFS_stochastics.meta +++ b/physics/GFS_stochastics.meta @@ -31,7 +31,7 @@ standard_name = sigma_pressure_hybrid_vertical_coordinate long_name = vertical sigma coordinate for radiation initialization units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index fe0e82390..993516e4f 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -78,7 +78,7 @@ standard_name = sigma_pressure_hybrid_coordinate_a_coefficient long_name = a parameter for sigma pressure level calculations units = Pa - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -86,7 +86,7 @@ standard_name = sigma_pressure_hybrid_coordinate_b_coefficient long_name = b parameter for sigma pressure level calculations units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta index 64d6b0d64..3ffcf909c 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/ugwpv1_gsldrag.meta @@ -84,7 +84,7 @@ standard_name = sigma_pressure_hybrid_coordinate_a_coefficient long_name = a parameter for sigma pressure level calculations units = Pa - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -92,7 +92,7 @@ standard_name = sigma_pressure_hybrid_coordinate_b_coefficient long_name = b parameter for sigma pressure level calculations units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 547256681..246ca236e 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -86,7 +86,7 @@ standard_name = sigma_pressure_hybrid_coordinate_a_coefficient long_name = a parameter for sigma pressure level calculations units = Pa - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -94,7 +94,7 @@ standard_name = sigma_pressure_hybrid_coordinate_b_coefficient long_name = b parameter for sigma pressure level calculations units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in From 98aba4a6b62e3600de76a9c74c4a09e0ce783ebe Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 23 Nov 2021 10:03:07 -0700 Subject: [PATCH 031/212] Suggested improvements for Thompson effective radii calculation and consistency checking --- physics/GFS_rrtmg_pre.F90 | 44 ++++++++++---------------- physics/module_mp_thompson.F90 | 10 ------ physics/mp_thompson.F90 | 58 ++++++++++++++++++++-------------- 3 files changed, 50 insertions(+), 62 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index ca3bf0e70..92f9d7122 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -193,9 +193,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & effrl, effri, effrr, effrs, rho, orho, plyrpa ! for Thompson MP - 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 + real(kind=kind_phys), dimension(im,lm+LTP) :: & + qv_mp, qc_mp, qi_mp, qs_mp, & + nc_mp, ni_mp, nwfa real (kind=kind_phys), dimension(lm) :: cldfra1d, qv1d, & & qc1d, qi1d, qs1d, dz1d, p1d, t1d @@ -796,37 +796,25 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ! it will raise the low limit from 5 to 10, but the high limit will remain 125. call calc_effectRad (tlyr(i,:), plyr(i,:)*100., qv_mp(i,:), qc_mp(i,:), & nc_mp(i,:), qi_mp(i,:), ni_mp(i,:), qs_mp(i,:), & - re_cloud(i,:), re_ice(i,:), re_snow(i,:), 1, lm ) + effrl(i,:), effri(i,:), effrs(i,:), 1, lm ) do k=1,lm - re_cloud(i,k) = MAX(re_qc_min, MIN(re_cloud(i,k), re_qc_max)) - re_ice(i,k) = MAX(re_qi_min, MIN(re_ice(i,k), re_qi_max)) - re_snow(i,k) = MAX(re_qs_min, MIN(re_snow(i,k), re_qs_max)) - end do - end do - ! Scale Thompson's effective radii from meter to micron - do k=1,lm - do i=1,im - re_cloud(i,k) = re_cloud(i,k)*1.e6 - re_ice(i,k) = re_ice(i,k)*1.e6 - re_snow(i,k) = re_snow(i,k)*1.e6 + effrl(i,k) = MAX(re_qc_min, MIN(effrl(i,k), re_qc_max)) + effri(i,k) = MAX(re_qi_min, MIN(effri(i,k), re_qi_max)) + effrr(i,k) = 1000. ! rrain_def=1000. + effrs(i,k) = MAX(re_qs_min, MIN(effrs(i,k), re_qs_max)) end do + effrl(i,lmk) = re_qc_min + effri(i,lmk) = re_qi_min + effrr(i,lmk) = 1000. ! rrain_def=1000. + effrs(i,lmk) = re_qs_min end do + ! Update global arrays, scale Thompson's effective radii from meter to micron do k=1,lm k1 = k + kd do i=1,im - effrl(i,k1) = re_cloud (i,k) - effri(i,k1) = re_ice (i,k) - effrr(i,k1) = 1000. ! rrain_def=1000. - effrs(i,k1) = re_snow(i,k) - 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) + effrl_inout(i,k) = effrl(i,k1)*1.e6 + effri_inout(i,k) = effri(i,k1)*1.e6 + effrs_inout(i,k) = effrs(i,k1)*1.e6 enddo enddo else ! all other cases diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 353f83c78..3c7e6ec2b 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1252,16 +1252,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ndt = max(nint(dt_in/dt_inner),1) dt = dt_in/ndt if(dt_in .le. dt_inner) dt= dt_in - if(nsteps>1 .and. ndt>1) then - if (present(errmsg) .and. present(errflg)) then - write(errmsg, '(a)') 'Logic error in mp_gt_driver: inner loop cannot be used with subcycling' - errflg = 1 - return - else - write(*,'(a)') 'Warning: inner loop cannot be used with subcycling, resetting ndt=1' - ndt = 1 - endif - endif do it = 1, ndt diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index d5a1fcaad..d5111cf63 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -379,6 +379,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! Reduced time step if subcycling is used real(kind_phys) :: dtstep + integer :: ndt ! Air density real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 ! Water vapor mixing ratio (instead of specific humidity) @@ -458,11 +459,39 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & errmsg = '' errflg = 0 - ! Check initialization state - if (.not.is_initialized) then - write(errmsg, fmt='((a))') 'mp_thompson_run called before mp_thompson_init' - errflg = 1 - return + if (first_time_step .and. istep==1 .and. blkno==1) then + ! Check initialization state + if (.not.is_initialized) then + write(errmsg, fmt='((a))') 'mp_thompson_run called before mp_thompson_init' + errflg = 1 + return + end if + ! Check forr optional arguments of aerosol-aware microphysics + if (is_aerosol_aware .and. .not. (present(nc) .and. & + present(nwfa) .and. & + present(nifa) .and. & + present(nwfa2d) .and. & + present(nifa2d) )) then + write(errmsg,fmt='(*(a))') 'Logic error in mp_thompson_run:', & + ' aerosol-aware microphysics require all of the', & + ' following optional arguments:', & + ' nc, nwfa, nifa, nwfa2d, nifa2d' + errflg = 1 + return + end if + ! Consistency cheecks - subcycling and inner loop at the same time are not supported + if (nsteps>1 .and. dt_inner < dtp) then + write(errmsg,'(*(a))') "Logic error: Subcycling and inner loop cannot be used at the same time" + errflg = 1 + return + else if (mpirank==mpiroot .and. nsteps>1) then + write(*,'(a,i0,a,a,f6.2,a)') 'Thompson MP is using ', nsteps, ' substep(s) per time step with an ', & + 'effective time step of ', dtp/real(nsteps, kind=kind_phys), ' seconds' + else if (mpirank==mpiroot .and. dt_inner < dtp) then + ndt = max(nint(dtp/dt_inner),1) + write(*,'(a,i0,a,a,f6.2,a)') 'Thompson MP is using ', ndt, ' inner loops per time step with an ', & + 'effective time step of ', dtp/real(ndt, kind=kind_phys), ' seconds' + end if end if ! Set reduced time step if subcycling is used @@ -471,25 +500,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & else dtstep = dtp end if - if (first_time_step .and. istep==1 .and. mpirank==mpiroot .and. blkno==1) then - write(*,'(a,i0,a,a,f6.2,a)') 'Thompson MP is using ', nsteps, ' substep(s) per time step', & - ' with an effective time step of ', dtstep, ' seconds' - end if - - if (first_time_step .and. istep==1) then - if (is_aerosol_aware .and. .not. (present(nc) .and. & - present(nwfa) .and. & - present(nifa) .and. & - present(nwfa2d) .and. & - present(nifa2d) )) then - write(errmsg,fmt='(*(a))') 'Logic error in mp_thompson_run:', & - ' aerosol-aware microphysics require all of the', & - ' following optional arguments:', & - ' nc, nwfa, nifa, nwfa2d, nifa2d' - errflg = 1 - return - end if - end if !> - Convert specific humidity to water vapor mixing ratio. !> - Also, hydrometeor variables are mass or number mixing ratio From 9fcd6da96fe74d6fd24b638d1743d527528781ef Mon Sep 17 00:00:00 2001 From: Laurie Carson Date: Tue, 23 Nov 2021 12:28:46 -0700 Subject: [PATCH 032/212] checkout dtc/ccpp branch (not main), for rte-rrtmgp --- physics/rte-rrtmgp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 9c01f0e22..56c549450 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 9c01f0e225f493b5b993aee709a59bec1c445e86 +Subproject commit 56c549450787cc7f592a66b4005a299244056568 From 12f92fb9bb3b260e4395a79fa46fc791a64d95e1 Mon Sep 17 00:00:00 2001 From: Laurie Carson Date: Tue, 23 Nov 2021 12:33:35 -0700 Subject: [PATCH 033/212] remove optional keyword from metadata files --- physics/GFS_rrtmg_pre.meta | 3 --- physics/drag_suite.meta | 3 --- physics/module_MYNNPBL_wrapper.meta | 3 --- physics/module_MYNNSFC_wrapper.meta | 3 --- physics/mp_thompson.meta | 3 --- physics/unified_ugwp.meta | 3 --- 6 files changed, 18 deletions(-) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index a4e5a0d62..7049ffed7 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1034,7 +1034,6 @@ type = real kind = kind_phys intent = out - optional = F [spp_wts_rad] standard_name = weights_for_stochastic_spp_rad_perturbation long_name = weights for stochastic spp rad perturbation @@ -1043,7 +1042,6 @@ type = real kind = kind_phys intent = in - optional = F [do_spp] standard_name = flag_for_stochastic_spp_option long_name = flag for stochastic spp option @@ -1051,7 +1049,6 @@ dimensions = () 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/drag_suite.meta b/physics/drag_suite.meta index df27b51af..4ef257f95 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -624,7 +624,6 @@ dimensions = () type = logical intent = in - optional = F [spp_wts_gwd] standard_name = weights_for_stochastic_spp_gwd_perturbation long_name = weights for stochastic spp gwd perturbation @@ -633,7 +632,6 @@ type = real kind = kind_phys intent = in - optional = F [do_spp] standard_name = flag_for_stochastic_spp_option long_name = flag for stochastic spp option @@ -641,7 +639,6 @@ dimensions = () 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/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 8efeea11b..db05bf4d8 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1264,7 +1264,6 @@ dimensions = () type = logical intent = in - optional = F [spp_wts_pbl] standard_name = weights_for_stochastic_spp_pbl_perturbation long_name = weights for stochastic spp pbl perturbation @@ -1273,7 +1272,6 @@ type = real kind = kind_phys intent = in - optional = F [do_spp] standard_name = flag_for_stochastic_spp_option long_name = flag for stochastic spp option @@ -1281,7 +1279,6 @@ dimensions = () type = logical intent = in - optional = F [lprnt] standard_name = flag_print long_name = control flag for diagnostic print out diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index 901256efe..91f55ac74 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -827,7 +827,6 @@ type = real kind = kind_phys intent = inout - optional = F [spp_wts_sfc] standard_name = weights_for_stochastic_spp_sfc_perturbation long_name = weights for stochastic spp sfc perturbation @@ -836,7 +835,6 @@ type = real kind = kind_phys intent = in - optional = F [do_spp] standard_name = flag_for_stochastic_spp_option long_name = flag for stochastic spp option @@ -844,7 +842,6 @@ dimensions = () type = logical intent = in - optional = F [lprnt] standard_name = flag_print long_name = control flag for diagnostic print out diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 245c68da5..52daa1c42 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -638,7 +638,6 @@ dimensions = () type = logical intent = in - optional = F [spp_wts_mp] standard_name = weights_for_stochastic_spp_mp_perturbation long_name = weights for stochastic spp mp perturbation @@ -647,7 +646,6 @@ type = real kind = kind_phys intent = in - optional = F [do_spp] standard_name = flag_for_stochastic_spp_option long_name = flag for stochastic spp option @@ -655,7 +653,6 @@ dimensions = () 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/unified_ugwp.meta b/physics/unified_ugwp.meta index eff265ba6..5ed4e9370 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -1178,7 +1178,6 @@ dimensions = () type = integer intent = in - optional = F [spp_wts_gwd] standard_name = weights_for_stochastic_spp_gwd_perturbation long_name = weights for stochastic spp gwd perturbation @@ -1187,7 +1186,6 @@ type = real kind = kind_phys intent = in - optional = F [do_spp] standard_name = flag_for_stochastic_spp_option long_name = flag for stochastic spp option @@ -1195,7 +1193,6 @@ dimensions = () type = logical intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From a851742e606313644316e1d57fa23b6cfad4d71b Mon Sep 17 00:00:00 2001 From: Laurie Carson Date: Tue, 23 Nov 2021 12:37:31 -0700 Subject: [PATCH 034/212] specific commit hash for rte-rrtmgp --- physics/rte-rrtmgp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 56c549450..9c51cb7c3 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 56c549450787cc7f592a66b4005a299244056568 +Subproject commit 9c51cb7c3e227c9e84c2bff29ce4f438c7a54ae6 From d5414d2a3ac26ec49c639c29c18ab9d8db12dc46 Mon Sep 17 00:00:00 2001 From: Laurie Carson Date: Tue, 23 Nov 2021 14:02:05 -0700 Subject: [PATCH 035/212] Add spp args to gwd call, when called directly (vs unified gwd) --- physics/ugwpv1_gsldrag.F90 | 9 +++++++-- physics/ugwpv1_gsldrag.meta | 15 +++++++++++++++ 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 71193ed88..72cc5e6f5 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -321,7 +321,8 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd zogw, zlwb, zobl, zngw, dusfcg, dvsfcg, dudt, dvdt, dtdt, rdxzb, & dtend, dtidx, index_of_x_wind, index_of_y_wind, index_of_temperature, & index_of_process_orographic_gwd, index_of_process_nonorographic_gwd, & - lprnt, ipr, errmsg, errflg) + lprnt, ipr, spp_wts_gwd, do_spp, errmsg, errflg) + ! !######################################################################## ! Attention New Arrays and Names must be ADDED inside @@ -436,6 +437,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd real(kind=kind_phys), intent(out), dimension(:) :: rdxzb ! for stoch phys. mtb-level + real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) + logical, intent(in) :: do_spp + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -558,7 +562,8 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & dtend, dtidx, index_of_process_orographic_gwd, & index_of_temperature, index_of_x_wind, & - index_of_y_wind, ldiag3d, errmsg, errflg) + index_of_y_wind, ldiag3d, spp_wts_gwd,do_spp, & + errmsg, errflg) ! ! dusfcg = du_ogwcol + du_oblcol + du_osscol + du_ofdcol ! diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta index 64d6b0d64..f4cdf685b 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/ugwpv1_gsldrag.meta @@ -1082,6 +1082,21 @@ dimensions = () type = integer intent = in +[spp_wts_gwd] + standard_name = weights_for_stochastic_spp_gwd_perturbation + long_name = weights for stochastic spp gwd perturbation + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[do_spp] + standard_name = flag_for_stochastic_spp_option + long_name = flag for stochastic spp option + units = flag + dimensions = () + type = logical + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 12ccaddd72fe83a9148eae9e4bd2f1a6282dea72 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 6 Dec 2021 08:19:30 -0700 Subject: [PATCH 036/212] Fix compile error in physics/radiation_clouds.f --- physics/radiation_clouds.f | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 3f6c54d5d..d8c6f9f59 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3139,10 +3139,10 @@ subroutine progcld6 & clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) if (.not. lmfshal) then - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 + tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) + tem1 = 2000.0 / tem1 else - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan if (lmfdeep2) then tem1 = xrc3 / tem1 else From 4b42e194a696fcfbdf8de646f3f9ce55104582fd Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 31 Mar 2021 20:59:17 -0500 Subject: [PATCH 037/212] - 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 038/212] - 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 039/212] 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 040/212] - 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 041/212] 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 042/212] 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 043/212] 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 044/212] 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 045/212] 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 046/212] - 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 047/212] 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 048/212] 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 049/212] 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 050/212] 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 051/212] 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 052/212] 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 053/212] 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 054/212] - 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 055/212] 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 056/212] 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 057/212] 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 058/212] 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 059/212] 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 060/212] 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 061/212] 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 062/212] 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 063/212] 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 7f444eea81e5f391ab8c119b5d70f7276e1ec0c9 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 9 Dec 2021 21:12:17 -0700 Subject: [PATCH 064/212] Revert Ruiyu's changes in this branch --- physics/GFS_rrtmg_pre.F90 | 10 +------ physics/radiation_clouds.f | 53 +++++++++++++++----------------------- 2 files changed, 22 insertions(+), 41 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index f2efd9d26..b8c2edd7f 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -864,14 +864,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo endif - if(imp_physics == imp_physics_thompson) then - do k=1,lm - k1 = k + kd - do i=1,im - cnvw (i,k1) = cnvw_in(i,k) - enddo - enddo - endif if (imp_physics == imp_physics_zhao_carr) then ccnd(1:IM,1:LMK,1) = ccnd(1:IM,1:LMK,1) + cnvw(1:IM,1:LMK) @@ -1001,7 +993,7 @@ 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), cnvw, effrl_inout, & + cldcov(:,1:LMK), effrl_inout, & effri_inout, effrs_inout, & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & dzb, xlat_d, julian, yearlen, & diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index b62f9f9e6..f58ec8d11 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -2881,7 +2881,7 @@ subroutine progcld6 & & xlat,xlon,slmsk,dz,delp, & & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & & IX, NLAY, NLP1, & - & uni_cld, lmfshal, lmfdeep2, cldcov, cnvw, & + & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, latdeg, julian, yearlen, & @@ -2976,7 +2976,7 @@ subroutine progcld6 & real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, dzlay, & - & re_cloud, re_ice, re_snow, cnvw + & re_cloud, re_ice, re_snow real (kind=kind_phys), dimension(:), intent(inout) :: & & lwp_ex, iwp_ex, lwp_fc, iwp_fc @@ -3010,8 +3010,8 @@ subroutine progcld6 & integer :: i, k, id, nf ! --- constant values - real (kind=kind_phys), parameter :: xrc3 = 200. -! real (kind=kind_phys), parameter :: xrc3 = 100. +! real (kind=kind_phys), parameter :: xrc3 = 200. + real (kind=kind_phys), parameter :: xrc3 = 100. ! !===> ... begin here @@ -3065,7 +3065,6 @@ subroutine progcld6 & do k = 1, NLAY do i = 1, IX clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) + clw(i,k,ntsw) - & +clw(i,k,ntrw) + cnvw(i,k) enddo enddo !> - Find top pressure for each cloud domain for given latitude. @@ -3092,9 +3091,8 @@ subroutine progcld6 & 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)) - csp(i,k) = max(0.0, clw(i,k,ntsw) * gfac * delp(i,k)) + csp(i,k) = max(0.0, (clw(i,k,ntsw)+clw(i,k,ntgl)) * & + & gfac * delp(i,k)) enddo enddo @@ -3127,36 +3125,27 @@ subroutine progcld6 & clwmin = 0.0 do k = 1, NLAY-1 do i = 1, IX -! clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - clwt = 1.0e-10 * (plyr(i,k)*0.001) + clwt = 1.0e-6 * (plyr(i,k)*0.001) if (clwf(i,k) > clwt) then - if(rhly(i,k) > 1.) 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 ) + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - if (.not. lmfshal) then - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 + if (.not. lmfshal) then + tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) + tem1 = 2000.0 / tem1 + else + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 else - 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 ) + tem1 = 100.0 / tem1 endif endif - else - cldtot(i,k) = 0.0 + + 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 From 5ebe5dc62ae85946c9ff092203a304bd2740074d Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Mon, 13 Dec 2021 14:36:41 -0700 Subject: [PATCH 065/212] following early results by Anning, make fewer clouds, especially high clouds --- physics/GFS_rrtmg_pre.F90 | 4 +++- physics/radiation_clouds.f | 12 ++++++------ 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 3a3378e15..cb20e69fb 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -216,6 +216,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real (kind=kind_phys) :: max_relh integer :: iflag + integer :: ii_half integer :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte @@ -236,7 +237,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & LP1 = LM + 1 ! num of in/out levels - gridkm = sqrt(2.0)*sqrt(dx(1)*0.001*dx(1)*0.001) + ii_half = nint(0.5*LM) + gridkm = sqrt(dx(1)*0.001*dx(ii_half)*0.001) if (imp_physics == imp_physics_thompson) then max_relh = 1.5 diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index f58ec8d11..84dfb2667 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3452,7 +3452,7 @@ subroutine progcld_thompson & do i = 1, IX cwp(i,k) = max(0.0, clw(i,k,ntcw) * dz(i,k)*1.E6) crp(i,k) = 0.0 - snow_mass_factor = 0.85 + snow_mass_factor = 0.90 cip(i,k) = max(0.0, (clw(i,k,ntiw) & & + (1.0-snow_mass_factor)*clw(i,k,ntsw))*dz(i,k)*1.E6) if (re_snow(i,k) .gt. snow_max_radius)then @@ -4532,8 +4532,8 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & DO k = kts,kte delz = MAX(100., dz(k)) - RH_00L = 0.74+MIN(0.25,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) - RH_00O = 0.82+MIN(0.17,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00L = 0.77+MIN(0.22,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00O = 0.85+MIN(0.14,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) RHUM = rh(k) if (qc(k).ge.1.E-5 .or. qi(k).ge.1.E-5 & @@ -4550,7 +4550,7 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & RH_00 = RH_00L ENDIF - tc = t(k) - 273.15 + tc = MAX(-80.0, t(k) - 273.15) if (tc .lt. -12.0) RH_00 = RH_00L if (tc .gt. 20.0) then @@ -4562,12 +4562,12 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & if (max_relh.gt.1.12 .or. (.NOT.(modify_qvapor)) ) then !..For HRRR model, the following look OK. RHUM = MIN(rh(k), 1.45) - RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+112.) + RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+85.) CLDFRA(K) = MAX(0.,1.0-SQRT((1.46-RHUM)/(1.46-RH_00))) else !..but for the GFS model, RH is way lower. RHUM = MIN(rh(k), 1.05) - RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+112.) + RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+85.) CLDFRA(K) = MAX(0.,1.0-SQRT((1.06-RHUM)/(1.06-RH_00))) endif endif From b7ddc451611c47779e5092d181d3631affbaa356 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Tue, 14 Dec 2021 16:02:27 -0700 Subject: [PATCH 066/212] add in less LWC and IWC in the partly cloudy boxes --- physics/radiation_clouds.f | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 84dfb2667..823575ddd 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -4789,9 +4789,9 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) max_iwc = ABS(qvs(k2)-qvs(k1)) do k = k1, k2 - max_iwc = MAX(1.E-5, max_iwc - (qi(k)+qs(k))) + max_iwc = MAX(1.E-6, max_iwc - (qi(k)+qs(k))) enddo - max_iwc = MIN(2.E-3, max_iwc) + max_iwc = MIN(1.E-4, max_iwc) this_dz = 0.0 do k = k1, k2 @@ -4801,7 +4801,7 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) this_dz = this_dz + dz(k) endif this_iwc = max_iwc*this_dz/tdz - iwc = MAX(5.E-6, this_iwc*(1.-entr)) + iwc = MAX(1.E-6, this_iwc*(1.-entr)) if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.203.16) then qi(k) = qi(k) + cfr(k)*cfr(k)*iwc endif @@ -4830,9 +4830,9 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) ! print*, ' max_lwc = ', max_lwc, ' over DZ=',tdz do k = k1, k2 - max_lwc = MAX(1.E-5, max_lwc - qc(k)) + max_lwc = MAX(1.E-6, max_lwc - qc(k)) enddo - max_lwc = MIN(2.E-3, max_lwc) + max_lwc = MIN(1.E-4, max_lwc) this_dz = 0.0 do k = k1, k2 @@ -4842,7 +4842,7 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) this_dz = this_dz + dz(k) endif this_lwc = max_lwc*this_dz/tdz - lwc = MAX(5.E-6, this_lwc*(1.-entr)) + lwc = MAX(1.E-6, this_lwc*(1.-entr)) if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.253.16) then qc(k) = qc(k) + cfr(k)*cfr(k)*lwc endif From a1ca10e804d68eeb8c97ff2f8c57d52ad65868d8 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Thu, 16 Dec 2021 10:18:35 -0700 Subject: [PATCH 067/212] bug fix, LM should have been IM --- 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 cb20e69fb..cc68825e1 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -237,7 +237,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & LP1 = LM + 1 ! num of in/out levels - ii_half = nint(0.5*LM) + ii_half = nint(0.5*IM) gridkm = sqrt(dx(1)*0.001*dx(ii_half)*0.001) if (imp_physics == imp_physics_thompson) then From 79325a53d7ee77c9c378d59a1cfd506c5b0f78ee Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Fri, 17 Dec 2021 08:37:33 -0700 Subject: [PATCH 068/212] make gridkm even simpler --- physics/GFS_rrtmg_pre.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index cc68825e1..f08ff2752 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -216,7 +216,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real (kind=kind_phys) :: max_relh integer :: iflag - integer :: ii_half integer :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte @@ -237,8 +236,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & LP1 = LM + 1 ! num of in/out levels - ii_half = nint(0.5*IM) - gridkm = sqrt(dx(1)*0.001*dx(ii_half)*0.001) + gridkm = dx(nint(0.5*IM))*0.001 if (imp_physics == imp_physics_thompson) then max_relh = 1.5 From 20e3b7962495858506705e77294f1c51c38dad3b Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Fri, 17 Dec 2021 09:22:19 -0700 Subject: [PATCH 069/212] make gridkm array in X-dimension --- physics/GFS_rrtmg_pre.F90 | 7 +++---- physics/radiation_clouds.f | 8 ++++---- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index f08ff2752..f6f20487e 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -183,7 +183,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & integer :: i, j, k, k1, k2, lsk, lv, n, itop, ibtc, LP1, lla, llb, lya,lyb - real(kind=kind_phys) :: es, qs, delt, tem0d, gridkm, pfac + real(kind=kind_phys) :: es, qs, delt, tem0d, pfac + real(kind=kind_phys), dimension(im) :: gridkm real(kind=kind_phys), dimension(im) :: cvt1, cvb1, tem1d, tskn, xland @@ -235,9 +236,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & LP1 = LM + 1 ! num of in/out levels - - gridkm = dx(nint(0.5*IM))*0.001 - if (imp_physics == imp_physics_thompson) then max_relh = 1.5 else @@ -245,6 +243,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif do i = 1, IM + gridkm(i) = dx(i)*0.001 lwp_ex(i) = 0.0 iwp_ex(i) = 0.0 lwp_fc(i) = 0.0 diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 823575ddd..87a9620b2 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3311,7 +3311,7 @@ subroutine progcld_thompson & ! 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) ! -! gridkm : grid length in km ! +! gridkm (ix) : grid length in km ! ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! ! uni_cld : logical - true for cloud fraction from shoc ! @@ -3370,8 +3370,8 @@ subroutine progcld_thompson & 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, gridkm + real(kind=kind_phys), dimension(:), intent(in) :: latdeg, gridkm + real(kind=kind_phys), intent(in) :: julian integer, intent(in) :: yearlen ! --- outputs @@ -3518,7 +3518,7 @@ subroutine progcld_thompson & endif call cal_cldfra3(cldfra1d, qv1d, qc1d, qi1d, qs1d, dz1d, & - & p1d, t1d, xland, gridkm, & + & p1d, t1d, xland, gridkm(i), & & .false., max_relh, 1, nlay, .false.) do k = 1, NLAY From c6bd0ad91723771f92147c791c5859ecda5b2e4c Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 20 Dec 2021 17:08:44 -0700 Subject: [PATCH 070/212] Remove physics/rte-rrtmgp/rrtmgp/kernels-openacc/mo_gas_optics_kernels.F90 from list of RRTMGP schemes --- CMakeLists.txt | 1 - 1 file changed, 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index b8cb88418..b59a8ef33 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -80,7 +80,6 @@ set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_ ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_constants.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_reorder.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels-openacc/mo_gas_optics_kernels.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_string.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_rrtmgp_util_reorder_kernels.F90 From 9a60c107c292101df106fcef41ad763ab1665c37 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 20 Dec 2021 17:09:31 -0700 Subject: [PATCH 071/212] Write diag messages to stdout instead of stderr, use standard _OPENMP CPP directive --- physics/GFS_debug.F90 | 20 ++++++++++---------- physics/GFS_phys_time_vary.fv3.F90 | 8 ++++---- physics/GFS_phys_time_vary.scm.F90 | 8 ++++---- 3 files changed, 18 insertions(+), 18 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 23d1be573..9d5d24aa8 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -390,7 +390,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, #ifdef MPI use mpi #endif -#ifdef OPENMP +#ifdef _OPENMP use omp_lib #endif use GFS_typedefs, only: GFS_control_type, GFS_statein_type, & @@ -437,7 +437,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, mpisize = 1 mpicomm = 0 #endif -#ifdef OPENMP +#ifdef _OPENMP omprank = OMP_GET_THREAD_NUM() ompsize = nthreads #else @@ -445,7 +445,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, ompsize = 1 #endif -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif #ifdef MPI @@ -929,7 +929,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx2_tau', Grid%jindx2_tau ) endif end if -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif end do @@ -938,7 +938,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, #endif end do -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif #ifdef MPI @@ -1043,7 +1043,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup #ifdef MPI use mpi #endif -#ifdef OPENMP +#ifdef _OPENMP use omp_lib #endif use machine, only: kind_phys @@ -1092,7 +1092,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup mpisize = 1 mpicomm = 0 #endif -#ifdef OPENMP +#ifdef _OPENMP omprank = OMP_GET_THREAD_NUM() ompsize = nthreads #else @@ -1100,7 +1100,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup ompsize = 1 #endif -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif #ifdef MPI @@ -1451,7 +1451,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%precip_overlap_param', Interstitial%precip_overlap_param ) end if end if -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif end do @@ -1460,7 +1460,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup #endif end do -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif #ifdef MPI diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index d6155e6b1..35fe08252 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -7,7 +7,7 @@ !> @{ module GFS_phys_time_vary -#ifdef OPENMP +#ifdef _OPENMP use omp_lib #endif @@ -355,7 +355,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP section !--- if sncovr does not exist in the restart, need to create it if (all(sncovr < zero)) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters' !--- compute sncovr from existing variables !--- code taken directly from read_fix.f sncovr(:) = zero @@ -376,7 +376,7 @@ subroutine GFS_phys_time_vary_init ( !--- For RUC LSM: create sncovr_ice from sncovr if (lsm == lsm_ruc) then if (all(sncovr_ice < zero)) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: fill sncovr_ice with sncovr for RUC LSM' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: fill sncovr_ice with sncovr for RUC LSM' sncovr_ice(:) = sncovr(:) endif endif @@ -396,7 +396,7 @@ subroutine GFS_phys_time_vary_init ( !--- land and ice - not for restart runs lsm_init: if (.not.flag_restart) then if (lsm == lsm_noahmp .or. lsm == lsm_ruc) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: initialize albedo for land and ice' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: initialize albedo for land and ice' do ix=1,im albdvis_lnd(ix) = 0.2_kind_phys albdnir_lnd(ix) = 0.2_kind_phys diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index b06e46cdc..514988a48 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -6,7 +6,7 @@ !! aerosol, IN&CCN and surface properties updates. !> @{ module GFS_phys_time_vary - + use machine, only : kind_phys use mersenne_twister, only: random_setseed, random_number @@ -313,7 +313,7 @@ subroutine GFS_phys_time_vary_init ( !--- if sncovr does not exist in the restart, need to create it if (all(sncovr < zero)) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters' !--- compute sncovr from existing variables !--- code taken directly from read_fix.f sncovr(:) = zero @@ -334,7 +334,7 @@ subroutine GFS_phys_time_vary_init ( !--- For RUC LSM: create sncovr_ice from sncovr if (lsm == lsm_ruc) then if (all(sncovr_ice < zero)) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: fill sncovr_ice with sncovr for RUC LSM' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: fill sncovr_ice with sncovr for RUC LSM' sncovr_ice(:) = sncovr(:) endif endif @@ -351,7 +351,7 @@ subroutine GFS_phys_time_vary_init ( !--- land and ice - not for restart runs lsm_init: if (.not.flag_restart) then if (lsm == lsm_noahmp .or. lsm == lsm_ruc) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: initialize albedo for land and ice' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: initialize albedo for land and ice' do ix=1,im albdvis_lnd(ix) = 0.2_kind_phys albdnir_lnd(ix) = 0.2_kind_phys From ebd9495b819fe590628d635c4cb641190c712063 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 22 Dec 2021 06:38:53 -0700 Subject: [PATCH 072/212] Remove more duplicate modules from SCHEMES_OPENMP_OFF list in CMakeLists.txt --- CMakeLists.txt | 2 -- 1 file changed, 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index b59a8ef33..f16014cb7 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -107,8 +107,6 @@ set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_ ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_sw.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_fluxes.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_lw.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels-openacc/mo_rte_solver_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels-openacc/mo_optical_props_kernels.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_util_array.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels/mo_optical_props_kernels.F90 From c73a22a507c6d480e8ed2f34ab7436eaaccdcd51 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 22 Dec 2021 13:04:22 -0700 Subject: [PATCH 073/212] Move calculation fo effrr into its own loop --- physics/GFS_rrtmg_pre.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 615a83d0f..1252418c9 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -821,14 +821,16 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & do k=1,lm effrl(i,k) = MAX(re_qc_min, MIN(effrl(i,k), re_qc_max)) effri(i,k) = MAX(re_qi_min, MIN(effri(i,k), re_qi_max)) - effrr(i,k) = 1000. ! rrain_def=1000. effrs(i,k) = MAX(re_qs_min, MIN(effrs(i,k), re_qs_max)) end do effrl(i,lmk) = re_qc_min effri(i,lmk) = re_qi_min - effrr(i,lmk) = 1000. ! rrain_def=1000. effrs(i,lmk) = re_qs_min end do + do k=1,lm + k1 = k + kd + effrr(i,k1) = 1000. ! rrain_def=1000. + end do ! Update global arrays, scale Thompson's effective radii from meter to micron do k=1,lm k1 = k + kd From b6dcb52209056db5bd0b552f2ffa81c2cc23e725 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 22 Dec 2021 13:32:37 -0700 Subject: [PATCH 074/212] Add missing i-loop around effrr in physics/GFS_rrtmg_pre.F90 --- physics/GFS_rrtmg_pre.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 1252418c9..ced2d99a4 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -829,7 +829,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & end do do k=1,lm k1 = k + kd - effrr(i,k1) = 1000. ! rrain_def=1000. + do i=1,im + effrr(i,k1) = 1000. ! rrain_def=1000. + end do end do ! Update global arrays, scale Thompson's effective radii from meter to micron do k=1,lm From 5523ff7d2870392b0afb7605975652b149273a5d Mon Sep 17 00:00:00 2001 From: jeff beck Date: Tue, 28 Dec 2021 04:14:14 +0000 Subject: [PATCH 075/212] Add missing drag_suite.F90 SPP code --- physics/drag_suite.F90 | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 7c20a9cf0..cd45577fd 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -732,7 +732,7 @@ subroutine drag_suite_run( & ! determine reference level: maximum of 2*var and pbl heights ! do i = its,im - zlowtop(i) = 2. * var(i) + zlowtop(i) = 2. * var_stoch(i) enddo ! do i = its,im @@ -888,7 +888,7 @@ subroutine drag_suite_run( & ! ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 - ldrag(i) = ldrag(i) .or. var(i) .le. 0.0 + ldrag(i) = ldrag(i) .or. var_stoch(i) .le. 0.0 ! ! set all ri low level values to the low level value ! @@ -898,7 +898,7 @@ subroutine drag_suite_run( & ! if (.not.ldrag(i)) then bnv(i) = sqrt( bnv2(i,1) ) - fr(i) = bnv(i) * rulow(i) * 2. * var(i) * od(i) + fr(i) = bnv(i) * rulow(i) * 2. * var_stoch(i) * od(i) fr(i) = min(fr(i),frmax) xn(i) = ubar(i) * rulow(i) yn(i) = vbar(i) * rulow(i) @@ -982,7 +982,7 @@ subroutine drag_suite_run( & exit ENDIF enddo - if((xland(i)-1.5).le.0. .and. 2.*varss(i).le.hpbl(i))then + 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 ! cleff_ss = 3. * max(dx(i),cleff_ss) @@ -1001,8 +1001,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(i),varmax_ss) + & - MAX(0.,beta_ss*(varss(i)-varmax_ss)) + var_temp = MIN(varss_stoch(i),varmax_ss_stoch) + & + MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch)) ! 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) @@ -1016,8 +1016,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(i),varmax_ss) + & - MAX(0.,beta_ss*(varss(i)-varmax_ss)) + var_temp = MIN(varss_stoch(i),varmax_ss_stoch) + & + MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch)) ! 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) @@ -1081,8 +1081,8 @@ 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(i),varmax_fd) + & - MAX(0.,beta_fd*(varss(i)-varmax_fd)) + var_temp = MIN(varss_stoch(i),varmax_fd_stoch) + & + MAX(0.,beta_fd*(varss_stoch(i)-varmax_fd_stoch)) var_temp = MIN(var_temp, 250.) a1=0.00026615161*var_temp**2 ! a1=0.00026615161*MIN(varss(i),varmax)**2 @@ -1090,7 +1090,7 @@ subroutine drag_suite_run( & ! 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(i),hpbl(i)) + H_efold = max(2*varss_stoch(i),hpbl(i)) H_efold = min(H_efold,1500.) DO k=kts,km wsp=SQRT(u1(i,k)**2 + v1(i,k)**2) From c2e8bbf25b4b0dc1c0cb4208a1c35c8d6d8ae3e4 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Tue, 28 Dec 2021 04:30:31 +0000 Subject: [PATCH 076/212] Requested changes from code review. --- physics/GFS_rrtmg_pre.F90 | 2 +- physics/mp_thompson.F90 | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 893a0a002..5254aa843 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -104,7 +104,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & uni_cld, effr_in, do_mynnedmf, & lmfshal, lmfdeep2, pert_clds - logical, optional, intent(in) :: do_spp + logical, intent(in) :: do_spp real(kind_phys), intent(in) :: spp_wts_rad(:,:) real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 9e263ea19..6843a6cd0 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -373,6 +373,10 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg + + ! SPP + logical, intent(in) :: do_spp + real(kind_phys), intent(in) :: spp_wts_mp(:,:) ! Local variables @@ -403,8 +407,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer, parameter :: has_reqi = 0 integer, parameter :: has_reqs = 0 integer, parameter :: kme_stoch = 1 - logical, intent(in ) :: do_spp - real(kind_phys), intent(in) :: spp_wts_mp(:,:) integer :: spp_mp ! Dimensions used in mp_gt_driver integer :: ids,ide, jds,jde, kds,kde, & From 307a507f24829210b88e7abf7e6872cdacc50462 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Tue, 28 Dec 2021 18:40:43 +0000 Subject: [PATCH 077/212] Fix dimension-related bug. --- physics/drag_suite.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index cd45577fd..df3ecb254 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -1001,8 +1001,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) + & - MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch)) + var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & + MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_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) @@ -1016,8 +1016,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) + & - MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch)) + var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & + MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_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) @@ -1081,8 +1081,8 @@ 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) + & - MAX(0.,beta_fd*(varss_stoch(i)-varmax_fd_stoch)) + 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.) a1=0.00026615161*var_temp**2 ! a1=0.00026615161*MIN(varss(i),varmax)**2 From 5a933125338806e4542f51d9912f513ee5a620c8 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Thu, 6 Jan 2022 11:09:29 -0700 Subject: [PATCH 078/212] alter aerosol surface emission based on a WRF change tested by Jimy Dudhia --- physics/mp_thompson.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index e96f0e112..d60b9f77f 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -91,7 +91,7 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & real(kind_phys) :: orho(1:ncol,1:nlev) ! m3 kg-1 real(kind_phys) :: nc_local(1:ncol,1:nlev) ! needed because nc is only allocated if is_aerosol_aware is true ! - real (kind=kind_phys) :: h_01, airmass, niIN3, niCCN3 + real (kind=kind_phys) :: h_01, z1, niIN3, niCCN3 integer :: i, k ! Initialize the CCPP error handling variables @@ -192,8 +192,8 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & endif niCCN3 = -1.0*ALOG(naCCN1/naCCN0)/h_01 nwfa(i,1) = naCCN1+naCCN0*exp(-((hgt(i,2)-hgt(i,1))/1000.)*niCCN3) - airmass = 1./orho(i,1) * (hgt(i,2)-hgt(i,1))*area(i) ! kg - nwfa2d(i) = nwfa(i,1) * 0.000196 * (airmass*5.E-11) + z1 = hgt(i,2)-hgt(i,1) + nwfa2d(i) = nwfa(i,1) * 0.000196 * (50./z1) do k = 2, nlev nwfa(i,k) = naCCN1+naCCN0*exp(-((hgt(i,k)-hgt(i,1))/1000.)*niCCN3) enddo @@ -212,8 +212,8 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & !+---+-----------------------------------------------------------------+ if (mpirank==mpiroot) write(*,*) ' Apparently there are no initial CCN aerosol surface emission rates.' do i = 1, ncol - airmass = 1./orho(i,1) * (hgt(i,2)-hgt(i,1))*area(i) ! kg - nwfa2d(i) = nwfa(i,1) * 0.000196 * (airmass*5.E-11) + z1 = hgt(i,2)-hgt(i,1) + nwfa2d(i) = nwfa(i,1) * 0.000196 * (50./z1) enddo else if (mpirank==mpiroot) write(*,*) ' Apparently initial CCN aerosol surface emission rates are present.' From a45d641173850a9aa7ec398a8176254d8f587bca Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Thu, 6 Jan 2022 11:19:59 -0700 Subject: [PATCH 079/212] one more tuning for reducing cloud ice amounts in partly cloudy boxes --- physics/radiation_clouds.f | 40 ++++++++++++++++---------------------- 1 file changed, 17 insertions(+), 23 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 87a9620b2..3122a0c43 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3164,7 +3164,8 @@ subroutine progcld6 & enddo enddo - ! What portion of water and ice contents is associated with the partly cloudy boxes + ! What portion of water and ice contents is associated with the + ! partly cloudy boxes do i = 1, IX do k = 1, NLAY-1 if (cldtot(i,k).ge.climit .and. cldtot(i,k).lt.ovcst) then @@ -3311,7 +3312,7 @@ subroutine progcld_thompson & ! 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) ! -! gridkm (ix) : grid length in km ! +! gridkm (IX) : grid length in km ! ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! ! uni_cld : logical - true for cloud fraction from shoc ! @@ -3445,14 +3446,14 @@ subroutine progcld_thompson & enddo !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . -!> - Since using Thompson MP, assume 20 percent of snow is actually in +!> - Since using Thompson MP, assume 1 percent of snow is actually in !! ice sizes. do k = 1, NLAY-1 do i = 1, IX cwp(i,k) = max(0.0, clw(i,k,ntcw) * dz(i,k)*1.E6) crp(i,k) = 0.0 - snow_mass_factor = 0.90 + snow_mass_factor = 0.99 cip(i,k) = max(0.0, (clw(i,k,ntiw) & & + (1.0-snow_mass_factor)*clw(i,k,ntsw))*dz(i,k)*1.E6) if (re_snow(i,k) .gt. snow_max_radius)then @@ -4536,12 +4537,12 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & RH_00O = 0.85+MIN(0.14,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) RHUM = rh(k) - if (qc(k).ge.1.E-5 .or. qi(k).ge.1.E-5 & - & .or. (qs(k).gt.1.E-5 .and. t(k).lt.273.)) then + if (qc(k).ge.1.E-6 .or. qi(k).ge.1.E-7 & + & .or. (qs(k).gt.1.E-6 .and. t(k).lt.273.)) then CLDFRA(K) = 1.0 elseif (((qc(k)+qi(k)).gt.1.E-10) .and. & - & ((qc(k)+qi(k)).lt.1.E-5)) then - CLDFRA(K) = MIN(0.99, 0.20*(10.0 + log10(qc(k)+qi(k)))) + & ((qc(k)+qi(k)).lt.1.E-6)) then + CLDFRA(K) = MIN(0.99, 0.1*(11.0 + log10(qc(k)+qi(k)))) else IF ((XLAND-1.5).GT.0.) THEN !--- Ocean @@ -4585,15 +4586,6 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & call adjust_cloudFinal(cldfra, qc, qi, rhoa, dz, kts,kte) - if (debug_flag .and. ndebug.lt.25) then - do k = kts,kte - write(6,'(a,i3,f9.2,f7.1,f7.2,f6.1,f6.3,f12.7,f12.7,f12.7)') & - & ' DEBUG-GT: ', k, p(k)*0.01, dz(k), t(k)-273.15, & - & rh(k)*100., cldfra(k), qc(k)*1.E3, qi(k)*1.E3, qs(k)*1.E3 - enddo - ndebug = ndebug + 1 - endif - !..Intended for cold start model runs, we use modify_qvapor to ensure that cloudy !.. areas are actually saturated such that the inserted clouds do not evaporate a !.. timestep later. @@ -4735,9 +4727,9 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, entrmnt,& k = k - 1 ENDDO - k_cldb = k_m12C + 5 + k_cldb = k_m12C + 3 in_cloud = .false. - k = k_m12C + 4 + k = k_m12C + 2 DO WHILE (.not. in_cloud .AND. k.gt.kbot) k_cldt = 0 if (cfr1d(k).ge.0.01) then @@ -4786,7 +4778,8 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) do k = k1, k2 tdz = tdz + dz(k) enddo - max_iwc = ABS(qvs(k2)-qvs(k1)) +! max_iwc = ABS(qvs(k2)-qvs(k1)) + max_iwc = MAX(0.0, qvs(k1)-qvs(k2)) do k = k1, k2 max_iwc = MAX(1.E-6, max_iwc - (qi(k)+qs(k))) @@ -4826,7 +4819,8 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) do k = k1, k2 tdz = tdz + dz(k) enddo - max_lwc = ABS(qvs(k2)-qvs(k1)) +! max_lwc = ABS(qvs(k2)-qvs(k1)) + max_lwc = MAX(0.0, qvs(k1)-qvs(k2)) ! print*, ' max_lwc = ', max_lwc, ' over DZ=',tdz do k = k1, k2 @@ -4843,7 +4837,7 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) endif this_lwc = max_lwc*this_dz/tdz lwc = MAX(1.E-6, this_lwc*(1.-entr)) - if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.253.16) then + if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.258.16) then qc(k) = qc(k) + cfr(k)*cfr(k)*lwc endif enddo @@ -4895,6 +4889,6 @@ SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte) END SUBROUTINE adjust_cloudFinal !........................................! - end module module_radiation_clouds ! + end module module_radiation_clouds !! @} !========================================! From 2181d0c6e19df42ed0a50f195068519fa06b2a43 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Thu, 6 Jan 2022 11:22:31 -0700 Subject: [PATCH 080/212] reduce max ice number conc to fewer than 500 per liter of air --- physics/module_mp_thompson.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 3183ca4bf..c5bc99e17 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -2188,7 +2188,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ni(k) = MAX(R2, ni1d(k)*rho(k)) if (ni(k).le. R2) then lami = cie(2)/5.E-6 - ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) endif L_qi(k) = .true. lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi @@ -2196,7 +2196,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i @@ -2901,7 +2901,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Freezing of aqueous aerosols based on Koop et al (2001, Nature) xni = smo0(k)+ni(k) + (pni_rfz(k)+pni_wfz(k)+pni_inu(k))*dtsave - if (is_aerosol_aware .AND. homogIce .AND. (xni.le.999.E3) & + if (is_aerosol_aware .AND. homogIce .AND. (xni.le.499.E3) & & .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then xnc = iceKoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave) pni_iha(k) = xnc*odts @@ -3237,7 +3237,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - xni = MIN(999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) + xni = MIN(499.D3, cig(1)*oig2*xri/am_i*lami**bm_i) niten(k) = (xni-ni1d(k)*rho(k))*odts*orho elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 @@ -3248,8 +3248,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & niten(k) = -ni1d(k)*odts endif xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k)) - if (xni.gt.999.E3) & - niten(k) = (999.E3-ni1d(k)*rho(k))*odts*orho + if (xni.gt.499.E3) & + niten(k) = (499.E3-ni1d(k)*rho(k))*odts*orho !> - Rain tendency qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) & @@ -4187,7 +4187,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lami = cie(2)/300.E-6 endif ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 999.D3/rho(k)) + 499.D3/rho(k)) endif qr1d(k) = qr1d(k) + qrten(k)*DT nr1d(k) = MAX(R2/rho(k), nr1d(k) + nrten(k)*DT) From 1a72e9891b8580537fa13e400c7850248b1e8bf4 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sun, 9 Jan 2022 09:08:15 -0700 Subject: [PATCH 081/212] Bugfix for cloud effective radii computation: scale local arrays from m to micron --- physics/GFS_rrtmg_pre.F90 | 37 +++++++++++++++---------------------- 1 file changed, 15 insertions(+), 22 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 80caf766e..0e398b1b9 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -818,28 +818,24 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & call calc_effectRad (tlyr(i,:), plyr(i,:)*100., qv_mp(i,:), qc_mp(i,:), & nc_mp(i,:), qi_mp(i,:), ni_mp(i,:), qs_mp(i,:), & effrl(i,:), effri(i,:), effrs(i,:), 1, lm ) + ! Scale Thompson's effective radii from meter to micron do k=1,lm - effrl(i,k) = MAX(re_qc_min, MIN(effrl(i,k), re_qc_max)) - effri(i,k) = MAX(re_qi_min, MIN(effri(i,k), re_qi_max)) - effrs(i,k) = MAX(re_qs_min, MIN(effrs(i,k), re_qs_max)) + effrl(i,k) = MAX(re_qc_min, MIN(effrl(i,k), re_qc_max))*1.e6 + effri(i,k) = MAX(re_qi_min, MIN(effri(i,k), re_qi_max))*1.e6 + effrs(i,k) = MAX(re_qs_min, MIN(effrs(i,k), re_qs_max))*1.e6 end do - effrl(i,lmk) = re_qc_min - effri(i,lmk) = re_qi_min - effrs(i,lmk) = re_qs_min + effrl(i,lmk) = re_qc_min*1.e6 + effri(i,lmk) = re_qi_min*1.e6 + effrs(i,lmk) = re_qs_min*1.e6 end do + effrr(:,:) = 1000. ! rrain_def=1000. + ! Update global arrays do k=1,lm k1 = k + kd do i=1,im - effrr(i,k1) = 1000. ! rrain_def=1000. - end do - end do - ! Update global arrays, scale Thompson's effective radii from meter to micron - do k=1,lm - k1 = k + kd - do i=1,im - effrl_inout(i,k) = effrl(i,k1)*1.e6 - effri_inout(i,k) = effri(i,k1)*1.e6 - effrs_inout(i,k) = effrs(i,k1)*1.e6 + effrl_inout(i,k) = effrl(i,k1) + effri_inout(i,k) = effri(i,k1) + effrs_inout(i,k) = effrs(i,k1) enddo enddo else ! all other cases @@ -964,8 +960,7 @@ 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, lm, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LM), effrl_inout, & - effri_inout, effrs_inout, & + 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 @@ -998,8 +993,7 @@ 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, lm, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LM), effrl_inout, & - effri_inout, effrs_inout, & + 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 @@ -1010,8 +1004,7 @@ 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), cnvw, effrl_inout, & - effri_inout, effrs_inout, & + 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 From e44b9aa4bc7985fe1d9d9e7602a266e5544d3ce1 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Wed, 12 Jan 2022 20:23:29 +0000 Subject: [PATCH 082/212] Changes for PR modification requests --- physics/GFS_rrtmg_pre.F90 | 6 +-- physics/GFS_rrtmg_pre.meta | 14 +++---- physics/drag_suite.F90 | 8 ++-- physics/drag_suite.meta | 14 +++---- physics/module_MYNNPBL_wrapper.F90 | 12 ++---- physics/module_MYNNPBL_wrapper.meta | 14 +++---- physics/module_MYNNSFC_wrapper.F90 | 11 ++---- physics/module_MYNNSFC_wrapper.meta | 14 +++---- physics/module_mp_thompson.F90 | 2 +- physics/module_sf_mynn.F90 | 60 ++++++++++++++--------------- physics/mp_thompson.F90 | 16 ++++---- physics/mp_thompson.meta | 14 +++---- physics/ugwpv1_gsldrag.F90 | 6 +-- physics/ugwpv1_gsldrag.meta | 14 +++---- physics/unified_ugwp.F90 | 6 +-- physics/unified_ugwp.meta | 14 +++---- 16 files changed, 109 insertions(+), 116 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index b1f56c21f..3ad790614 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -36,7 +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, & - spp_wts_rad, do_spp, errmsg, errflg) + spp_wts_rad, spp_rad, errmsg, errflg) use machine, only: kind_phys @@ -104,7 +104,7 @@ 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) :: do_spp + 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 @@ -1080,7 +1080,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo ! --- add spp - if ( do_spp .ne. 0 ) then + if ( spp_rad==1 ) then do k=1,lm if (k < levs) then diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index f0568458f..c9aa88aae 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1083,19 +1083,19 @@ kind = kind_phys intent = out [spp_wts_rad] - standard_name = weights_for_stochastic_spp_rad_perturbation - long_name = weights for stochastic spp rad perturbation + standard_name = weights_for_stochastic_spp_rad_perturbations + long_name = weights for stochastic spp rad perturbations units = none dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in -[do_spp] - standard_name = flag_for_stochastic_spp_option - long_name = flag for stochastic spp option - units = flag +[spp_rad] + standard_name = control_for_radiation_spp_perturbations + long_name = control for radiation spp perturbations + units = count dimensions = () - type = logical + type = integer intent = in [errmsg] standard_name = ccpp_error_message diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index df3ecb254..919484e87 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -219,7 +219,7 @@ subroutine drag_suite_run( & & dtend, dtidx, index_of_process_orographic_gwd, & & index_of_temperature, index_of_x_wind, & & index_of_y_wind, ldiag3d, & - & spp_wts_gwd, do_spp, errmsg, errflg) + & spp_wts_gwd, spp_gwd, errmsg, errflg) ! ******************************************************************** ! -----> I M P L E M E N T A T I O N V E R S I O N <---------- @@ -369,7 +369,7 @@ subroutine drag_suite_run( & real(kind=kind_phys), dimension(im) :: var_stoch, varss_stoch, & varmax_ss_stoch, varmax_fd_stoch real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) - logical, intent(in) :: do_spp + integer, intent(in) :: spp_gwd real(kind=kind_phys), dimension(im) :: rstoch @@ -601,8 +601,8 @@ subroutine drag_suite_run( & endif enddo -! SPP, if do_spp is false, no perturbations are applied. -if ( do_spp ) then +! SPP, if spp_gwd is 0, no perturbations are applied. +if ( spp_gwd==1 ) then do i = its,im var_stoch(i) = var(i) + var(i)*0.75*spp_wts_gwd(i,1) varss_stoch(i) = varss(i) + varss(i)*0.75*spp_wts_gwd(i,1) diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index 7f2c50237..e5ed1e9f3 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -625,19 +625,19 @@ type = logical intent = in [spp_wts_gwd] - standard_name = weights_for_stochastic_spp_gwd_perturbation - long_name = weights for stochastic spp gwd perturbation + standard_name = weights_for_stochastic_spp_gwd_perturbations + long_name = weights for stochastic spp gwd perturbations units = none dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in -[do_spp] - standard_name = flag_for_stochastic_spp_option - long_name = flag for stochastic spp option - units = flag +[spp_gwd] + standard_name = control_for_gravity_wave_drag_spp_perturbations + long_name = control for gravity wave drag spp perturbations + units = count dimensions = () - type = logical + type = integer intent = in [errmsg] standard_name = ccpp_error_message diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 0aa2648f3..7c0ba1ba4 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -108,7 +108,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & ltaerosol, spp_wts_pbl, do_spp, lprnt, huge, errmsg, errflg ) + & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: use machine , only : kind_phys @@ -195,7 +195,6 @@ SUBROUTINE mynnedmf_wrapper_run( & ! NAMELIST OPTIONS (INPUT): LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect, ltaerosol, & lprnt, do_mynnsfclay, & - do_spp, & flag_for_pbl_generic_tend INTEGER, INTENT(IN) :: & & bl_mynn_cloudpdf, & @@ -210,7 +209,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, & + & spp_pbl !TENDENCY DIAGNOSTICS real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) @@ -232,7 +232,6 @@ SUBROUTINE mynnedmf_wrapper_run( & LOGICAL, PARAMETER :: cycling = .false. INTEGER, PARAMETER :: param_first_scalar = 1 INTEGER :: & - & spp_pbl, & & p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni !MYNN-1D @@ -277,7 +276,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & Tsq, Qsq, Cov, exch_h, exch_m real(kind=kind_phys), dimension(:), intent(in) :: xmu real(kind=kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw - ! spp_wts_pbl only allocated if do_spp == .true. + ! spp_wts_pbl only allocated if spp_pbl == 1 real(kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl !LOCAL @@ -531,9 +530,6 @@ SUBROUTINE mynnedmf_wrapper_run( & w(i,k) = -omega(i,k)/(rho(i,k)*g) enddo enddo - if ( do_spp ) then - spp_pbl=1 - endif do i=1,im if (slmsk(i)==1. .or. slmsk(i)==2.) then !sea/land/ice mask (=0/1/2) in FV3 diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 0d024498b..8f313bcbc 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1258,19 +1258,19 @@ type = logical intent = in [spp_wts_pbl] - standard_name = weights_for_stochastic_spp_pbl_perturbation - long_name = weights for stochastic spp pbl perturbation + standard_name = weights_for_stochastic_spp_pbl_perturbations + long_name = weights for stochastic spp pbl perturbations units = none dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in -[do_spp] - standard_name = flag_for_stochastic_spp_option - long_name = flag for stochastic spp option - units = flag +[spp_pbl] + standard_name = control_for_planetary_boundary_layer_spp_perturbations + long_name = control for planetary boundary layer spp perturbations + units = count dimensions = () - type = logical + type = integer intent = in [lprnt] standard_name = flag_print diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index 4032f8b30..e49891a18 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -88,7 +88,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & FLHC, FLQC, & & U10, V10, TH2, T2, Q2, & & wstar, CHS2, CQS2, & - & spp_wts_sfc, do_spp, & + & spp_wts_sfc, spp_sfc, & ! & CP, G, ROVCP, R, XLV, & ! & SVP1, SVP2, SVP3, SVPT0, & ! & EP1,EP2,KARMAN, & @@ -155,7 +155,7 @@ SUBROUTINE mynnsfc_wrapper_run( & 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) - logical, intent(in) :: do_spp ! flag for using SPP perturbations + integer, intent(in) :: spp_sfc ! flag for using SPP perturbations real(kind=kind_phys), intent(in) :: delt @@ -213,7 +213,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & dz, th, qv !MYNN-1D - INTEGER :: k, i, spp_sfc + INTEGER :: k, i INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE, & & IMS,IME,JMS,JME,KMS,KME, & & ITS,ITE,JTS,JTE,KTS,KTE @@ -239,9 +239,6 @@ SUBROUTINE mynnsfc_wrapper_run( & qv(i,k)=qvsh(i,k)/(1.0 - qvsh(i,k)) enddo enddo - if ( do_spp ) then - spp_sfc=1 - endif do i=1,im if (slmsk(i)==1. .or. slmsk(i)==2.)then !sea/land/ice mask (=0/1/2) in FV3 @@ -336,7 +333,7 @@ SUBROUTINE mynnsfc_wrapper_run( & QGH=qgh,QSFC=qsfc, & U10=u10,V10=v10,TH2=th2,T2=t2,Q2=q2, & GZ1OZ0=GZ1OZ0,WSPD=wspd,wstar=wstar, & - spp_pbl=spp_sfc,pattern_spp_pbl=spp_wts_sfc, & + spp_sfc=spp_sfc,pattern_spp_sfc=spp_wts_sfc, & ids=1,ide=im, jds=1,jde=1, kds=1,kde=levs, & ims=1,ime=im, jms=1,jme=1, kms=1,kme=levs, & its=1,ite=im, jts=1,jte=1, kts=1,kte=levs ) diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index 99468fd7c..c1ef9fe69 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -835,19 +835,19 @@ kind = kind_phys intent = inout [spp_wts_sfc] - standard_name = weights_for_stochastic_spp_sfc_perturbation - long_name = weights for stochastic spp sfc perturbation + standard_name = weights_for_stochastic_spp_sfc_perturbations + long_name = weights for stochastic spp sfc perturbations units = none dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in -[do_spp] - standard_name = flag_for_stochastic_spp_option - long_name = flag for stochastic spp option - units = flag +[spp_sfc] + standard_name = control_for_surface_layer_spp_perturbations + long_name = control for surface layer spp perturbations + units = count dimensions = () - type = logical + type = integer intent = in [lprnt] standard_name = flag_print diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 5b975aaad..788a3010b 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1290,7 +1290,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & !+---+-----------------------------------------------------------------+ !..Introduce stochastic parameter perturbations by creating as many scalar rand1, rand2, ... !.. variables as needed to perturb different pieces of microphysics. gthompsn 21Mar2018 -! Setting spp_mp to 1 gives graupel Y-intercept pertubations (2^0) +! Setting spp_mp_opt to 1 gives graupel Y-intercept pertubations (2^0) ! 2 gives cloud water distribution gamma shape parameter perturbations (2^1) ! 4 gives CCN & IN activation perturbations (2^2) ! 3 gives both 1+2 diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index c98dc2169..f2bc66e52 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -161,7 +161,7 @@ SUBROUTINE SFCLAY_mynn( & QGH,QSFC, & U10,V10,TH2,T2,Q2, & GZ1OZ0,WSPD,WSTAR, & - spp_pbl,pattern_spp_pbl, & + spp_sfc,pattern_spp_sfc, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -271,7 +271,7 @@ SUBROUTINE SFCLAY_mynn( & !NAMELIST/CONFIGURATION OPTIONS: INTEGER, INTENT(IN) :: ISFFLX, LSM, LSM_RUC INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN) :: spp_pbl, psi_opt + INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt 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) @@ -293,7 +293,7 @@ SUBROUTINE SFCLAY_mynn( & th3d,pi3d REAL, DIMENSION( ims:ime, kms:kme), OPTIONAL, & - INTENT(IN) :: pattern_spp_pbl + INTENT(IN) :: pattern_spp_sfc !=================================== ! 2D VARIABLES !=================================== @@ -396,8 +396,8 @@ SUBROUTINE SFCLAY_mynn( & QC1D(i)=QC3D(i,kts) P1D(i) =P3D(i,kts) T1D(i) =T3D(i,kts) - if (spp_pbl==1) then - rstoch1D(i)=pattern_spp_pbl(i,kts) + if (spp_sfc==1) then + rstoch1D(i)=pattern_spp_sfc(i,kts) else rstoch1D(i)=0.0 endif @@ -462,7 +462,7 @@ SUBROUTINE SFCLAY_mynn( & HFLX,HFX,QFLX,QFX,LH,FLHC,FLQC, & QGH,QSFC,U10,V10,TH2,T2,Q2, & GZ1OZ0,WSPD,wstar, & - spp_pbl,rstoch1D, & + spp_sfc,rstoch1D, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -510,7 +510,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & QGH,QSFC, & U10,V10,TH2,T2,Q2, & GZ1OZ0,WSPD,wstar, & - spp_pbl,rstoch1D, & + spp_sfc,rstoch1D, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -537,7 +537,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !----------------------------- INTEGER, INTENT(IN) :: ISFFLX INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - INTEGER, INTENT(IN) :: spp_pbl, psi_opt + 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 logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -1111,7 +1111,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif !-end wave model check ! add stochastic perturbation of ZNT - if (spp_pbl==1) then + if (spp_sfc==1) then ZNTstoch_wat(I) = MAX(ZNT_wat(I) + ZNT_wat(I)*1.0*rstoch1D(i), 1e-6) else ZNTstoch_wat(I) = ZNT_wat(I) @@ -1140,29 +1140,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF ( ISFTCFLX .EQ. 0 ) THEN IF (COARE_OPT .EQ. 3.0) THEN CALL fairall_etal_2003(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ELSE !presumably, this will be published soon, but hasn't yet CALL fairall_etal_2014(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ENDIF ELSEIF ( ISFTCFLX .EQ. 1 ) THEN IF (COARE_OPT .EQ. 3.0) THEN CALL fairall_etal_2003(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ELSE CALL fairall_etal_2014(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ENDIF ELSEIF ( ISFTCFLX .EQ. 2 ) THEN CALL garratt_1992(ZT_wat(i),ZQ_wat(i),ZNTstoch_wat(i),restar,2.0) ELSEIF ( ISFTCFLX .EQ. 3 ) THEN IF (COARE_OPT .EQ. 3.0) THEN CALL fairall_etal_2003(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ELSE CALL fairall_etal_2014(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ENDIF ELSEIF ( ISFTCFLX .EQ. 4 ) THEN !GFS zt formulation @@ -1173,10 +1173,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !DEFAULT TO COARE 3.0/3.5 IF (COARE_OPT .EQ. 3.0) THEN CALL fairall_etal_2003(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ELSE CALL fairall_etal_2014(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ENDIF ENDIF IF (debug_code > 1) THEN @@ -1201,7 +1201,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif ! add stochastic perturbaction of ZNT - if (spp_pbl==1) then + if (spp_sfc==1) then ZNTstoch_lnd(I) = MAX(ZNT_lnd(I) + ZNT_lnd(I)*1.0*rstoch1D(i), 1e-6) else ZNTstoch_lnd(I) = ZNT_lnd(I) @@ -1222,7 +1222,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF ( PRESENT(IZ0TLND) ) THEN IF ( IZ0TLND .LE. 1 ) THEN CALL zilitinkevich_1995(ZNTstoch_lnd(i),ZT_lnd(i),ZQ_lnd(i),restar,& - UST_lnd(I),KARMAN,1.0,IZ0TLND,spp_pbl,rstoch1D(i)) + UST_lnd(I),KARMAN,1.0,IZ0TLND,spp_sfc,rstoch1D(i)) ELSEIF ( IZ0TLND .EQ. 2 ) THEN CALL Yang_2008(ZNTSTOCH_lnd(i),ZT_lnd(i),ZQ_lnd(i),UST_lnd(i),MOL(I),& qstar(I),restar,visc) @@ -1237,7 +1237,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ELSE !DEFAULT TO ZILITINKEVICH CALL zilitinkevich_1995(ZNTSTOCH_lnd(i),ZT_lnd(i),ZQ_lnd(i),restar,& - UST_lnd(I),KARMAN,1.0,0,spp_pbl,rstoch1D(i)) + UST_lnd(I),KARMAN,1.0,0,spp_sfc,rstoch1D(i)) ENDIF ENDIF IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN @@ -1263,7 +1263,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (icy(I)) THEN ! add stochastic perturbaction of ZNT - if (spp_pbl==1) then + if (spp_sfc==1) then ZNTstoch_ice(I) = MAX(ZNT_ice(I) + ZNT_ice(I)*1.0*rstoch1D(i), 1e-6) else ZNTstoch_ice(I) = ZNT_ice(I) @@ -2246,7 +2246,7 @@ END SUBROUTINE SFCLAY1D_mynn !! to work with the Noah LSM and may be specific for that !! LSM only. Tests with RUC LSM showed no improvements. SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& - & landsea,IZ0TLND2,spp_pbl,rstoch) + & landsea,IZ0TLND2,spp_sfc,rstoch) IMPLICIT NONE REAL, INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea @@ -2255,7 +2255,7 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& 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 + INTEGER, INTENT(IN) :: spp_sfc REAL, INTENT(IN) :: rstoch @@ -2296,7 +2296,7 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& ! stochastically perturb thermal and moisture roughness length. ! currently set to half the amplitude: - if (spp_pbl==1) then + if (spp_sfc==1) then Zt = Zt + Zt * 0.5 * rstoch Zt = MAX(Zt, 0.0001) Zq = Zt @@ -2461,11 +2461,11 @@ END SUBROUTINE garratt_1992 !!(1992, p. 102), is available for flows with Ren < 2. !! !!This is for use over water only. - SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_pbl) + SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) IMPLICIT NONE REAL, INTENT(IN) :: Ren,ustar,visc,rstoch - INTEGER, INTENT(IN):: spp_pbl + INTEGER, INTENT(IN):: spp_sfc REAL, INTENT(OUT) :: Zt,Zq IF (Ren .le. 2.) then @@ -2484,7 +2484,7 @@ SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_pbl) ENDIF - if (spp_pbl==1) then + if (spp_sfc==1) then Zt = Zt + Zt * 0.5 * rstoch Zq = Zt endif @@ -2505,18 +2505,18 @@ END SUBROUTINE fairall_etal_2003 !! COARE 3.5/4.0 formulation, empirically derived from COARE and HEXMAX data !! [Fairall et al. (2014? coming soon, not yet published as of July 2014)]. !! This is for use over water only. - SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_pbl) + SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) IMPLICIT NONE REAL, INTENT(IN) :: Ren,ustar,visc,rstoch - INTEGER, INTENT(IN):: spp_pbl + INTEGER, INTENT(IN):: spp_sfc REAL, INTENT(OUT) :: Zt,Zq !Zt = (5.5e-5)*(Ren**(-0.60)) Zt = MIN(1.6E-4, 5.8E-5/(Ren**0.72)) Zq = Zt - IF (spp_pbl ==1) THEN + IF (spp_sfc ==1) THEN Zt = MAX(Zt + Zt*0.5*rstoch,2.0e-9) Zq = MAX(Zt + Zt*0.5*rstoch,2.0e-9) ELSE diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 6843a6cd0..5316eb181 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -308,7 +308,7 @@ 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, do_spp, & + spp_wts_mp, spp_mp, & errmsg, errflg) implicit none @@ -375,7 +375,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer, intent( out) :: errflg ! SPP - logical, intent(in) :: do_spp + integer, intent(in) :: spp_mp real(kind_phys), intent(in) :: spp_wts_mp(:,:) ! Local variables @@ -407,7 +407,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer, parameter :: has_reqi = 0 integer, parameter :: has_reqs = 0 integer, parameter :: kme_stoch = 1 - integer :: spp_mp + integer :: spp_mp_opt ! Dimensions used in mp_gt_driver integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -466,10 +466,10 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & end if ! Set stochastic physics selection to apply all perturbations - if ( do_spp ) then - spp_mp=7 + if ( spp_mp ) then + spp_mp_opt=7 else - spp_mp=0 + spp_mp_opt=0 endif ! Set reduced time step if subcycling is used @@ -633,7 +633,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & refl_10cm=refl_10cm, & 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, kme_stoch=kme_stoch, & + rand_perturb_on=spp_mp_opt, kme_stoch=kme_stoch, & rand_pert=spp_wts_mp, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & @@ -670,7 +670,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & refl_10cm=refl_10cm, & 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, kme_stoch=kme_stoch, & + rand_perturb_on=spp_mp_opt, kme_stoch=kme_stoch, & rand_pert=spp_wts_mp, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 52daa1c42..896c01873 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -639,19 +639,19 @@ type = logical intent = in [spp_wts_mp] - standard_name = weights_for_stochastic_spp_mp_perturbation - long_name = weights for stochastic spp mp perturbation + standard_name = weights_for_stochastic_spp_mp_perturbations + long_name = weights for stochastic spp mp perturbations units = none dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in -[do_spp] - standard_name = flag_for_stochastic_spp_option - long_name = flag for stochastic spp option - units = flag +[spp_mp] + standard_name = control_for_microphysics_spp_perturbations + long_name = control for microphysics spp perturbations + units = count dimensions = () - type = logical + type = integer intent = in [errmsg] standard_name = ccpp_error_message diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 72cc5e6f5..3c4f3400f 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -321,7 +321,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd zogw, zlwb, zobl, zngw, dusfcg, dvsfcg, dudt, dvdt, dtdt, rdxzb, & dtend, dtidx, index_of_x_wind, index_of_y_wind, index_of_temperature, & index_of_process_orographic_gwd, index_of_process_nonorographic_gwd, & - lprnt, ipr, spp_wts_gwd, do_spp, errmsg, errflg) + lprnt, ipr, spp_wts_gwd, spp_gwd, errmsg, errflg) ! !######################################################################## @@ -438,7 +438,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd real(kind=kind_phys), intent(out), dimension(:) :: rdxzb ! for stoch phys. mtb-level real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) - logical, intent(in) :: do_spp + logical, intent(in) :: spp_gwd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -562,7 +562,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & dtend, dtidx, index_of_process_orographic_gwd, & index_of_temperature, index_of_x_wind, & - index_of_y_wind, ldiag3d, spp_wts_gwd,do_spp, & + index_of_y_wind, ldiag3d, spp_wts_gwd, spp_gwd, & errmsg, errflg) ! ! dusfcg = du_ogwcol + du_oblcol + du_osscol + du_ofdcol diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta index edce8c201..97113d20c 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/ugwpv1_gsldrag.meta @@ -1083,19 +1083,19 @@ type = integer intent = in [spp_wts_gwd] - standard_name = weights_for_stochastic_spp_gwd_perturbation - long_name = weights for stochastic spp gwd perturbation + standard_name = weights_for_stochastic_spp_gwd_perturbations + long_name = weights for stochastic spp gwd perturbations units = none dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in -[do_spp] - standard_name = flag_for_stochastic_spp_option - long_name = flag for stochastic spp option - units = flag +[spp_gwd] + standard_name = control_for_gravity_wave_drag_spp_perturbations + long_name = control for gravity wave drag spp perturbations + units = count dimensions = () - type = logical + type = integer intent = in [errmsg] standard_name = ccpp_error_message diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 491a4168c..9e93bd5fc 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -218,7 +218,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, index_of_process_orographic_gwd, index_of_process_nonorographic_gwd, & ldiag3d, lssav, flag_for_gwd_generic_tend, do_ugwp_v0, do_ugwp_v0_orog_only, & do_ugwp_v0_nst_only, do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & - gwd_opt, spp_wts_gwd, do_spp, errmsg, errflg) + gwd_opt, spp_wts_gwd, spp_gwd, errmsg, errflg) implicit none @@ -297,7 +297,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, do_gsl_drag_tofd real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) - logical, intent(in) :: do_spp + integer, intent(in) :: spp_gwd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -346,7 +346,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & dtend, dtidx, index_of_process_orographic_gwd, & index_of_temperature, index_of_x_wind, & - index_of_y_wind, ldiag3d, spp_wts_gwd,do_spp, & + index_of_y_wind, ldiag3d, spp_wts_gwd, spp_gwd, & errmsg, errflg) ! ! put zeros due to xy GSL-drag style: dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index d919e0b9e..46e79ea33 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -1179,19 +1179,19 @@ type = integer intent = in [spp_wts_gwd] - standard_name = weights_for_stochastic_spp_gwd_perturbation - long_name = weights for stochastic spp gwd perturbation + standard_name = weights_for_stochastic_spp_gwd_perturbations + long_name = weights for stochastic spp gwd perturbations units = none dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in -[do_spp] - standard_name = flag_for_stochastic_spp_option - long_name = flag for stochastic spp option - units = flag +[spp_gwd] + standard_name = control_for_gravity_wave_drag_spp_perturbations + long_name = control for gravity wave drag spp perturbations + units = count dimensions = () - type = logical + type = integer intent = in [errmsg] standard_name = ccpp_error_message From 8d599bc0608c30675568cc81424d16905646944c Mon Sep 17 00:00:00 2001 From: jeff beck Date: Thu, 13 Jan 2022 02:45:27 +0000 Subject: [PATCH 083/212] Fix bug in SPP implementation --- physics/GFS_rrtmg_pre.F90 | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 3ad790614..c63221075 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -1080,24 +1080,22 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo ! --- add spp - if ( spp_rad==1 ) then - - do k=1,lm - if (k < levs) then - do i=1,im - effrl_inout(i,k) = effrl_inout(i,k) - spp_wts_rad(i,k) * effrl_inout(i,k) - effri_inout(i,k) = effri_inout(i,k) - spp_wts_rad(i,k) * effri_inout(i,k) - effrs_inout(i,k) = effrs_inout(i,k) - spp_wts_rad(i,k) * effrs_inout(i,k) - enddo - else - do i=1,im - effrl_inout(i,k) = effrl_inout(i,k) - spp_wts_rad(i,levs) * effrl_inout(i,k) - effri_inout(i,k) = effri_inout(i,k) - spp_wts_rad(i,levs) * effri_inout(i,k) - effrs_inout(i,k) = effrs_inout(i,k) - spp_wts_rad(i,levs) * effrs_inout(i,k) - enddo - endif - enddo - + if ( spp_rad == 1 ) then + do k=1,lm + if (k < levs) then + do i=1,im + effrl_inout(i,k) = effrl_inout(i,k) - spp_wts_rad(i,k) * effrl_inout(i,k) + effri_inout(i,k) = effri_inout(i,k) - spp_wts_rad(i,k) * effri_inout(i,k) + effrs_inout(i,k) = effrs_inout(i,k) - spp_wts_rad(i,k) * effrs_inout(i,k) + enddo + else + do i=1,im + effrl_inout(i,k) = effrl_inout(i,k) - spp_wts_rad(i,levs) * effrl_inout(i,k) + effri_inout(i,k) = effri_inout(i,k) - spp_wts_rad(i,levs) * effri_inout(i,k) + effrs_inout(i,k) = effrs_inout(i,k) - spp_wts_rad(i,levs) * effrs_inout(i,k) + enddo + endif + enddo endif ! mg, sfc-perts From 6f898244276bf1f3e52f6fc084d4eb7b1963c1c9 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Fri, 14 Jan 2022 01:51:44 +0000 Subject: [PATCH 084/212] Perturb cloud* instead of effr*_inout --- physics/GFS_rrtmg_pre.F90 | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index c63221075..f4f413d0d 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -1079,20 +1079,19 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo -! --- add spp if ( spp_rad == 1 ) then do k=1,lm if (k < levs) then do i=1,im - effrl_inout(i,k) = effrl_inout(i,k) - spp_wts_rad(i,k) * effrl_inout(i,k) - effri_inout(i,k) = effri_inout(i,k) - spp_wts_rad(i,k) * effri_inout(i,k) - effrs_inout(i,k) = effrs_inout(i,k) - spp_wts_rad(i,k) * effrs_inout(i,k) + 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 - effrl_inout(i,k) = effrl_inout(i,k) - spp_wts_rad(i,levs) * effrl_inout(i,k) - effri_inout(i,k) = effri_inout(i,k) - spp_wts_rad(i,levs) * effri_inout(i,k) - effrs_inout(i,k) = effrs_inout(i,k) - spp_wts_rad(i,levs) * effrs_inout(i,k) + 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 From 9c90b4702eff5bc1c0ff924620e3b8a0b06448dd Mon Sep 17 00:00:00 2001 From: jeff beck Date: Fri, 14 Jan 2022 16:25:08 +0000 Subject: [PATCH 085/212] Change spp_gwd from logical to integer --- physics/ugwpv1_gsldrag.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 3c4f3400f..41290ed68 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -438,7 +438,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd real(kind=kind_phys), intent(out), dimension(:) :: rdxzb ! for stoch phys. mtb-level real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) - logical, intent(in) :: spp_gwd + integer, intent(in) :: spp_gwd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg From a7b987594372c4446103c3afa0310b5b98c45723 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Fri, 14 Jan 2022 19:41:26 +0000 Subject: [PATCH 086/212] MYNN SFC perturbation pattern name fix --- physics/module_MYNNSFC_wrapper.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index 852694329..c767d863a 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -231,7 +231,7 @@ SUBROUTINE mynnsfc_wrapper_run( & ! endif ! prep MYNN-only variables - pattern_spp_pbl(:,:) = 0 + pattern_spp_sfc(:,:) = 0 dz(:,:) = 0 th(:,:) = 0 qv(:,:) = 0 From dd419a3db2a9a1b825287c39da42610b1546dcb9 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Fri, 14 Jan 2022 19:54:52 +0000 Subject: [PATCH 087/212] Remove initialization of pattern_spp_sfc=0 --- physics/module_MYNNSFC_wrapper.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index c767d863a..150a66472 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -231,7 +231,6 @@ SUBROUTINE mynnsfc_wrapper_run( & ! endif ! prep MYNN-only variables - pattern_spp_sfc(:,:) = 0 dz(:,:) = 0 th(:,:) = 0 qv(:,:) = 0 From b88049ae2fe569574b54bd7e703a8d241b32e231 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 14 Jan 2022 19:30:23 -0600 Subject: [PATCH 088/212] 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 d466eb1fee4ffef9821247973d7aed16d5c8801a Mon Sep 17 00:00:00 2001 From: jeff beck Date: Sun, 16 Jan 2022 03:53:54 +0000 Subject: [PATCH 089/212] Updates to standard names and units --- physics/GFS_rrtmg_pre.meta | 6 +++--- physics/drag_suite.meta | 6 +++--- physics/module_MYNNPBL_wrapper.meta | 10 +++++----- physics/module_MYNNSFC_wrapper.meta | 6 +++--- physics/mp_thompson.meta | 6 +++--- physics/ugwpv1_gsldrag.meta | 6 +++--- physics/unified_ugwp.meta | 6 +++--- 7 files changed, 23 insertions(+), 23 deletions(-) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index c9aa88aae..675fc095a 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1083,9 +1083,9 @@ kind = kind_phys intent = out [spp_wts_rad] - standard_name = weights_for_stochastic_spp_rad_perturbations - long_name = weights for stochastic spp rad perturbations - units = none + 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 diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index e5ed1e9f3..ae474d1ee 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -625,9 +625,9 @@ type = logical intent = in [spp_wts_gwd] - standard_name = weights_for_stochastic_spp_gwd_perturbations - long_name = weights for stochastic spp gwd perturbations - units = none + standard_name = spp_weights_for_gravity_wave_drag_scheme + long_name = spp weights for gravity wave drag scheme + units = 1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 8f313bcbc..c8c1ca106 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1258,16 +1258,16 @@ type = logical intent = in [spp_wts_pbl] - standard_name = weights_for_stochastic_spp_pbl_perturbations - long_name = weights for stochastic spp pbl perturbations - units = none + standard_name = spp_weights_for_pbl_scheme + long_name = spp weights for pbl scheme + units = 1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in [spp_pbl] - standard_name = control_for_planetary_boundary_layer_spp_perturbations - long_name = control for planetary boundary layer spp perturbations + standard_name = control_for_pbl_spp_perturbations + long_name = control for pbl spp perturbations units = count dimensions = () type = integer diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index c1ef9fe69..ec0c183ed 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -835,9 +835,9 @@ kind = kind_phys intent = inout [spp_wts_sfc] - standard_name = weights_for_stochastic_spp_sfc_perturbations - long_name = weights for stochastic spp sfc perturbations - units = none + standard_name = spp_weights_for_surface_layer_scheme + long_name = spp weights for surface layer scheme + units = 1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 896c01873..ddddffb7f 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -639,9 +639,9 @@ type = logical intent = in [spp_wts_mp] - standard_name = weights_for_stochastic_spp_mp_perturbations - long_name = weights for stochastic spp mp perturbations - units = none + standard_name = spp_weights_for_microphysics_scheme + long_name = spp weights for microphysics scheme + units = 1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta index 34487e8a3..b0ca7c7fb 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/ugwpv1_gsldrag.meta @@ -1083,9 +1083,9 @@ type = integer intent = in [spp_wts_gwd] - standard_name = weights_for_stochastic_spp_gwd_perturbations - long_name = weights for stochastic spp gwd perturbations - units = none + standard_name = spp_weights_for_gravity_wave_drag_scheme + long_name = spp weights for gravity wave drag scheme + units = 1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index 181f0bd55..26fc6d6f4 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -1179,9 +1179,9 @@ type = integer intent = in [spp_wts_gwd] - standard_name = weights_for_stochastic_spp_gwd_perturbations - long_name = weights for stochastic spp gwd perturbations - units = none + standard_name = spp_weights_for_gravity_wave_drag_scheme + long_name = spp weights for gravity wave drag scheme + units = 1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys From d1527d5f9678e29b7cb959a1a07cf0b816bb0c12 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sun, 16 Jan 2022 06:23:19 -0700 Subject: [PATCH 090/212] Change standard_name and unit of CCPP error flag variable in all metadata files --- physics/GFS_DCNV_generic.meta | 12 ++--- physics/GFS_GWD_generic.meta | 12 ++--- physics/GFS_MP_generic.meta | 12 ++--- physics/GFS_PBL_generic.meta | 12 ++--- physics/GFS_SCNV_generic.meta | 12 ++--- physics/GFS_cloud_diagnostics.meta | 6 +-- physics/GFS_debug.meta | 66 +++++++++++------------ physics/GFS_phys_time_vary.fv3.meta | 24 ++++----- physics/GFS_phys_time_vary.scm.meta | 24 ++++----- physics/GFS_rad_time_vary.fv3.meta | 6 +-- physics/GFS_rad_time_vary.scm.meta | 6 +-- physics/GFS_radiation_surface.meta | 12 ++--- physics/GFS_rrtmg_post.meta | 6 +-- physics/GFS_rrtmg_pre.meta | 6 +-- physics/GFS_rrtmg_setup.meta | 18 +++---- physics/GFS_rrtmgp_cloud_overlap_pre.meta | 6 +-- physics/GFS_rrtmgp_gfdlmp_pre.meta | 6 +-- physics/GFS_rrtmgp_lw_post.meta | 6 +-- physics/GFS_rrtmgp_pre.meta | 12 ++--- physics/GFS_rrtmgp_setup.meta | 18 +++---- physics/GFS_rrtmgp_sw_post.meta | 6 +-- physics/GFS_rrtmgp_sw_pre.meta | 6 +-- physics/GFS_rrtmgp_thompsonmp_pre.meta | 6 +-- physics/GFS_rrtmgp_zhaocarr_pre.meta | 6 +-- physics/GFS_stochastics.meta | 12 ++--- physics/GFS_suite_interstitial.meta | 54 +++++++++---------- physics/GFS_surface_composites.meta | 18 +++---- physics/GFS_surface_generic.meta | 24 ++++----- physics/GFS_surface_loop_control.meta | 12 ++--- physics/GFS_time_vary_pre.fv3.meta | 18 +++---- physics/GFS_time_vary_pre.scm.meta | 18 +++---- physics/cires_ugwp.meta | 18 +++---- physics/cires_ugwp_post.meta | 6 +-- physics/cnvc90.meta | 6 +-- physics/cs_conv.meta | 18 +++---- physics/cs_conv_aw_adj.meta | 6 +-- physics/cu_gf_driver.meta | 12 ++--- physics/cu_gf_driver_post.meta | 6 +-- physics/cu_gf_driver_pre.meta | 6 +-- physics/cu_ntiedtke.meta | 12 ++--- physics/cu_ntiedtke_post.meta | 6 +-- physics/cu_ntiedtke_pre.meta | 6 +-- physics/dcyc2.meta | 6 +-- physics/drag_suite.meta | 12 ++--- physics/flake_driver.meta | 18 +++---- physics/gcm_shoc.meta | 12 ++--- physics/get_prs_fv3.meta | 12 ++--- physics/gfdl_cloud_microphys.meta | 18 +++---- physics/gfdl_fv_sat_adj.meta | 18 +++---- physics/gfdl_sfc_layer.meta | 12 ++--- physics/gscond.meta | 12 ++--- physics/gwdc.meta | 24 ++++----- physics/gwdps.meta | 6 +-- physics/h2ophys.meta | 12 ++--- physics/m_micro.meta | 12 ++--- physics/m_micro_interstitial.meta | 12 ++--- physics/maximum_hourly_diagnostics.meta | 6 +-- physics/module_MYJPBL_wrapper.meta | 12 ++--- physics/module_MYJSFC_wrapper.meta | 12 ++--- physics/module_MYNNPBL_wrapper.meta | 12 ++--- physics/module_MYNNSFC_wrapper.meta | 12 ++--- physics/module_SGSCloud_RadPost.meta | 6 +-- physics/module_SGSCloud_RadPre.meta | 6 +-- physics/moninedmf.meta | 12 ++--- physics/moninshoc.meta | 12 ++--- physics/mp_fer_hires.meta | 18 +++---- physics/mp_thompson.meta | 18 +++---- physics/mp_thompson_post.meta | 18 +++---- physics/mp_thompson_pre.meta | 6 +-- physics/ozphys.meta | 12 ++--- physics/ozphys_2015.meta | 12 ++--- physics/phys_tend.meta | 6 +-- physics/precpd.meta | 12 ++--- physics/radlw_main.meta | 6 +-- physics/radsw_main.meta | 6 +-- physics/rascnv.meta | 18 +++---- physics/rayleigh_damp.meta | 6 +-- physics/rrtmg_lw_post.meta | 6 +-- physics/rrtmg_lw_pre.meta | 6 +-- physics/rrtmg_sw_post.meta | 6 +-- physics/rrtmg_sw_pre.meta | 6 +-- physics/rrtmgp_lw_aerosol_optics.meta | 6 +-- physics/rrtmgp_lw_cloud_optics.meta | 12 ++--- physics/rrtmgp_lw_cloud_sampling.meta | 6 +-- physics/rrtmgp_lw_gas_optics.meta | 12 ++--- physics/rrtmgp_lw_pre.meta | 6 +-- physics/rrtmgp_lw_rte.meta | 6 +-- physics/rrtmgp_sw_aerosol_optics.meta | 6 +-- physics/rrtmgp_sw_cloud_optics.meta | 12 ++--- physics/rrtmgp_sw_cloud_sampling.meta | 6 +-- physics/rrtmgp_sw_gas_optics.meta | 12 ++--- physics/rrtmgp_sw_rte.meta | 6 +-- physics/samfdeepcnv.meta | 12 ++--- physics/samfshalcnv.meta | 12 ++--- physics/sascnvn.meta | 12 ++--- physics/satmedmfvdif.meta | 12 ++--- physics/satmedmfvdifq.meta | 12 ++--- physics/scm_sfc_flux_spec.meta | 12 ++--- physics/sfc_cice.meta | 6 +-- physics/sfc_diag.meta | 6 +-- physics/sfc_diag_post.meta | 6 +-- physics/sfc_diff.meta | 6 +-- physics/sfc_drv.meta | 18 +++---- physics/sfc_drv_ruc.meta | 18 +++---- physics/sfc_noahmp_drv.meta | 12 ++--- physics/sfc_nst.meta | 18 +++---- physics/sfc_ocean.meta | 6 +-- physics/sfc_sice.meta | 6 +-- physics/shalcnv.meta | 12 ++--- physics/shinhongvdif.meta | 12 ++--- physics/ugwpv1_gsldrag.meta | 18 +++---- physics/ugwpv1_gsldrag_post.meta | 6 +-- physics/unified_ugwp.meta | 18 +++---- physics/unified_ugwp_post.meta | 6 +-- physics/ysuvdif.meta | 12 ++--- 115 files changed, 675 insertions(+), 675 deletions(-) diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index c719ae96c..47fb65d9a 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -256,9 +256,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 @@ -708,9 +708,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 diff --git a/physics/GFS_GWD_generic.meta b/physics/GFS_GWD_generic.meta index f761ac5bc..78b2ee970 100644 --- a/physics/GFS_GWD_generic.meta +++ b/physics/GFS_GWD_generic.meta @@ -229,9 +229,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 @@ -383,9 +383,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 diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index 1bcbf4ab1..1526948e4 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -111,9 +111,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 @@ -853,9 +853,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 diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 3dcf81043..27c659c2c 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -368,9 +368,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 @@ -1238,9 +1238,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 diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index 90dc72d42..5cbda127c 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -249,9 +249,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 @@ -672,9 +672,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 diff --git a/physics/GFS_cloud_diagnostics.meta b/physics/GFS_cloud_diagnostics.meta index 986548b5a..aab5387d0 100644 --- a/physics/GFS_cloud_diagnostics.meta +++ b/physics/GFS_cloud_diagnostics.meta @@ -137,9 +137,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 diff --git a/physics/GFS_debug.meta b/physics/GFS_debug.meta index 2071a18c1..23175ce0f 100644 --- a/physics/GFS_debug.meta +++ b/physics/GFS_debug.meta @@ -37,9 +37,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 @@ -78,9 +78,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 @@ -189,9 +189,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 @@ -236,9 +236,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 @@ -277,9 +277,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 @@ -388,9 +388,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 @@ -428,9 +428,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 @@ -680,9 +680,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 @@ -764,9 +764,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 @@ -842,9 +842,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 @@ -927,9 +927,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 diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 0af6cda3c..e9dd388ce 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -897,9 +897,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 @@ -917,9 +917,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 @@ -1855,9 +1855,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 @@ -1875,9 +1875,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 diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta index 9c836e323..52e002aa0 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/GFS_phys_time_vary.scm.meta @@ -897,9 +897,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 @@ -917,9 +917,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 @@ -1369,9 +1369,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 @@ -1389,9 +1389,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 diff --git a/physics/GFS_rad_time_vary.fv3.meta b/physics/GFS_rad_time_vary.fv3.meta index 8a4938667..0e7c7c024 100644 --- a/physics/GFS_rad_time_vary.fv3.meta +++ b/physics/GFS_rad_time_vary.fv3.meta @@ -201,9 +201,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 diff --git a/physics/GFS_rad_time_vary.scm.meta b/physics/GFS_rad_time_vary.scm.meta index 8a4938667..0e7c7c024 100644 --- a/physics/GFS_rad_time_vary.scm.meta +++ b/physics/GFS_rad_time_vary.scm.meta @@ -201,9 +201,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 diff --git a/physics/GFS_radiation_surface.meta b/physics/GFS_radiation_surface.meta index 268edbb54..3fd851a40 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/GFS_radiation_surface.meta @@ -37,9 +37,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 @@ -485,9 +485,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 diff --git a/physics/GFS_rrtmg_post.meta b/physics/GFS_rrtmg_post.meta index 80bd5c22c..0f45a2126 100644 --- a/physics/GFS_rrtmg_post.meta +++ b/physics/GFS_rrtmg_post.meta @@ -275,9 +275,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 diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index ced68890e..48fc31c49 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1091,9 +1091,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 diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index d80faf8a5..ae0da3a5e 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -172,9 +172,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 @@ -268,9 +268,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 @@ -288,9 +288,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 diff --git a/physics/GFS_rrtmgp_cloud_overlap_pre.meta b/physics/GFS_rrtmgp_cloud_overlap_pre.meta index a15f1a8bd..a4620cfa2 100644 --- a/physics/GFS_rrtmgp_cloud_overlap_pre.meta +++ b/physics/GFS_rrtmgp_cloud_overlap_pre.meta @@ -234,9 +234,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 diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.meta b/physics/GFS_rrtmgp_gfdlmp_pre.meta index 1f0a7745b..c45054613 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.meta +++ b/physics/GFS_rrtmgp_gfdlmp_pre.meta @@ -295,9 +295,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 diff --git a/physics/GFS_rrtmgp_lw_post.meta b/physics/GFS_rrtmgp_lw_post.meta index 399f238d0..d458b25f3 100644 --- a/physics/GFS_rrtmgp_lw_post.meta +++ b/physics/GFS_rrtmgp_lw_post.meta @@ -245,9 +245,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 diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 15ce6db1a..501dacfa1 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -40,9 +40,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 @@ -433,9 +433,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 diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index ab9b0a49c..41bf63ac8 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -215,9 +215,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 @@ -311,9 +311,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 @@ -331,9 +331,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 diff --git a/physics/GFS_rrtmgp_sw_post.meta b/physics/GFS_rrtmgp_sw_post.meta index 6d661b7f1..0e93b78e6 100644 --- a/physics/GFS_rrtmgp_sw_post.meta +++ b/physics/GFS_rrtmgp_sw_post.meta @@ -363,9 +363,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 diff --git a/physics/GFS_rrtmgp_sw_pre.meta b/physics/GFS_rrtmgp_sw_pre.meta index 1d9f893b6..462ab5f18 100644 --- a/physics/GFS_rrtmgp_sw_pre.meta +++ b/physics/GFS_rrtmgp_sw_pre.meta @@ -116,9 +116,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 diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.meta b/physics/GFS_rrtmgp_thompsonmp_pre.meta index 82d9a1b95..ff8d0e13b 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.meta +++ b/physics/GFS_rrtmgp_thompsonmp_pre.meta @@ -369,9 +369,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 diff --git a/physics/GFS_rrtmgp_zhaocarr_pre.meta b/physics/GFS_rrtmgp_zhaocarr_pre.meta index 861b1144d..2eb333115 100644 --- a/physics/GFS_rrtmgp_zhaocarr_pre.meta +++ b/physics/GFS_rrtmgp_zhaocarr_pre.meta @@ -358,9 +358,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 diff --git a/physics/GFS_stochastics.meta b/physics/GFS_stochastics.meta index c78dbe015..bf1c3fb25 100644 --- a/physics/GFS_stochastics.meta +++ b/physics/GFS_stochastics.meta @@ -52,9 +52,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 @@ -495,9 +495,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 diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index f596b86cd..43b3d5efa 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -30,9 +30,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 @@ -70,9 +70,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 @@ -236,9 +236,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 @@ -725,9 +725,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 @@ -836,9 +836,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 @@ -1023,9 +1023,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 @@ -1468,9 +1468,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 @@ -1817,9 +1817,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 @@ -1901,9 +1901,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 diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index fde52ed23..89048e487 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -479,9 +479,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 @@ -613,9 +613,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 @@ -1650,9 +1650,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 diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 4dcf394db..6ad2953a6 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -94,9 +94,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 @@ -465,9 +465,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 @@ -533,9 +533,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 @@ -1485,9 +1485,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 diff --git a/physics/GFS_surface_loop_control.meta b/physics/GFS_surface_loop_control.meta index edb19072a..4a522ff43 100644 --- a/physics/GFS_surface_loop_control.meta +++ b/physics/GFS_surface_loop_control.meta @@ -45,9 +45,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 @@ -149,9 +149,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 diff --git a/physics/GFS_time_vary_pre.fv3.meta b/physics/GFS_time_vary_pre.fv3.meta index 4cd736667..3ec92287a 100644 --- a/physics/GFS_time_vary_pre.fv3.meta +++ b/physics/GFS_time_vary_pre.fv3.meta @@ -16,9 +16,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 @@ -36,9 +36,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 @@ -231,9 +231,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 diff --git a/physics/GFS_time_vary_pre.scm.meta b/physics/GFS_time_vary_pre.scm.meta index 908d636b0..20708c51e 100644 --- a/physics/GFS_time_vary_pre.scm.meta +++ b/physics/GFS_time_vary_pre.scm.meta @@ -16,9 +16,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 @@ -36,9 +36,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 @@ -224,9 +224,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 diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index 92421a94b..bf94edd26 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -161,9 +161,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 @@ -181,9 +181,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 @@ -858,9 +858,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 diff --git a/physics/cires_ugwp_post.meta b/physics/cires_ugwp_post.meta index 0faca669f..5add9d43f 100644 --- a/physics/cires_ugwp_post.meta +++ b/physics/cires_ugwp_post.meta @@ -269,9 +269,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 diff --git a/physics/cnvc90.meta b/physics/cnvc90.meta index 9c2a626fa..9728266d4 100644 --- a/physics/cnvc90.meta +++ b/physics/cnvc90.meta @@ -116,9 +116,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 diff --git a/physics/cs_conv.meta b/physics/cs_conv.meta index 68189d776..90a411031 100644 --- a/physics/cs_conv.meta +++ b/physics/cs_conv.meta @@ -141,9 +141,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 @@ -204,9 +204,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 @@ -613,9 +613,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 diff --git a/physics/cs_conv_aw_adj.meta b/physics/cs_conv_aw_adj.meta index f3c205772..0dada0fd5 100644 --- a/physics/cs_conv_aw_adj.meta +++ b/physics/cs_conv_aw_adj.meta @@ -173,9 +173,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 diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index 3fb9fe232..311a9cb3e 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -58,9 +58,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 @@ -562,9 +562,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 diff --git a/physics/cu_gf_driver_post.meta b/physics/cu_gf_driver_post.meta index c3d3e897c..b50c2ab40 100644 --- a/physics/cu_gf_driver_post.meta +++ b/physics/cu_gf_driver_post.meta @@ -85,9 +85,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 diff --git a/physics/cu_gf_driver_pre.meta b/physics/cu_gf_driver_pre.meta index c587939bd..7fd66d19b 100644 --- a/physics/cu_gf_driver_pre.meta +++ b/physics/cu_gf_driver_pre.meta @@ -131,9 +131,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 diff --git a/physics/cu_ntiedtke.meta b/physics/cu_ntiedtke.meta index 68a9827c8..dded8fb20 100644 --- a/physics/cu_ntiedtke.meta +++ b/physics/cu_ntiedtke.meta @@ -58,9 +58,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 @@ -319,9 +319,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 diff --git a/physics/cu_ntiedtke_post.meta b/physics/cu_ntiedtke_post.meta index 4d83bf57c..703d32b90 100644 --- a/physics/cu_ntiedtke_post.meta +++ b/physics/cu_ntiedtke_post.meta @@ -48,9 +48,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 diff --git a/physics/cu_ntiedtke_pre.meta b/physics/cu_ntiedtke_pre.meta index 5b162041a..ccb9b7f48 100644 --- a/physics/cu_ntiedtke_pre.meta +++ b/physics/cu_ntiedtke_pre.meta @@ -101,9 +101,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 diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index 122d6a8e1..8df27a3c2 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -630,9 +630,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 diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index ba9d4050d..c7af87f0b 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -23,9 +23,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 @@ -633,9 +633,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 diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index 2855aa026..7ed80d866 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -16,9 +16,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 @@ -36,9 +36,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 @@ -306,9 +306,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 diff --git a/physics/gcm_shoc.meta b/physics/gcm_shoc.meta index d22e51e6a..984c6aec5 100644 --- a/physics/gcm_shoc.meta +++ b/physics/gcm_shoc.meta @@ -23,9 +23,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 @@ -400,9 +400,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 diff --git a/physics/get_prs_fv3.meta b/physics/get_prs_fv3.meta index 90630a255..4e893b45c 100644 --- a/physics/get_prs_fv3.meta +++ b/physics/get_prs_fv3.meta @@ -86,9 +86,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 @@ -174,9 +174,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 diff --git a/physics/gfdl_cloud_microphys.meta b/physics/gfdl_cloud_microphys.meta index 6f6b1d47f..5e752b473 100644 --- a/physics/gfdl_cloud_microphys.meta +++ b/physics/gfdl_cloud_microphys.meta @@ -81,9 +81,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 @@ -101,9 +101,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 @@ -472,9 +472,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 diff --git a/physics/gfdl_fv_sat_adj.meta b/physics/gfdl_fv_sat_adj.meta index 8eece5a9c..5cdc96358 100644 --- a/physics/gfdl_fv_sat_adj.meta +++ b/physics/gfdl_fv_sat_adj.meta @@ -74,9 +74,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 @@ -94,9 +94,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 @@ -431,9 +431,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 diff --git a/physics/gfdl_sfc_layer.meta b/physics/gfdl_sfc_layer.meta index 228ab4bca..f1c7a4ce2 100644 --- a/physics/gfdl_sfc_layer.meta +++ b/physics/gfdl_sfc_layer.meta @@ -58,9 +58,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 @@ -721,9 +721,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 diff --git a/physics/gscond.meta b/physics/gscond.meta index e46b73618..4c5fd02c3 100644 --- a/physics/gscond.meta +++ b/physics/gscond.meta @@ -37,9 +37,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 @@ -298,9 +298,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 diff --git a/physics/gwdc.meta b/physics/gwdc.meta index 2e8076bca..e61559e92 100644 --- a/physics/gwdc.meta +++ b/physics/gwdc.meta @@ -132,9 +132,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 @@ -165,9 +165,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 @@ -409,9 +409,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 @@ -596,9 +596,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 diff --git a/physics/gwdps.meta b/physics/gwdps.meta index e483354df..3ce1c5b74 100644 --- a/physics/gwdps.meta +++ b/physics/gwdps.meta @@ -319,9 +319,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 diff --git a/physics/h2ophys.meta b/physics/h2ophys.meta index 759666baf..afe50bda1 100644 --- a/physics/h2ophys.meta +++ b/physics/h2ophys.meta @@ -23,9 +23,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 @@ -118,9 +118,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 diff --git a/physics/m_micro.meta b/physics/m_micro.meta index e202f7b74..99ebb591f 100644 --- a/physics/m_micro.meta +++ b/physics/m_micro.meta @@ -289,9 +289,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 @@ -835,9 +835,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 diff --git a/physics/m_micro_interstitial.meta b/physics/m_micro_interstitial.meta index 031ebbe5a..c7c8a23fd 100644 --- a/physics/m_micro_interstitial.meta +++ b/physics/m_micro_interstitial.meta @@ -250,9 +250,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 @@ -440,9 +440,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 diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index d9a236c29..6f7a055b8 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -240,9 +240,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 diff --git a/physics/module_MYJPBL_wrapper.meta b/physics/module_MYJPBL_wrapper.meta index 43e63b4ab..427088b86 100644 --- a/physics/module_MYJPBL_wrapper.meta +++ b/physics/module_MYJPBL_wrapper.meta @@ -23,9 +23,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 @@ -659,9 +659,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 diff --git a/physics/module_MYJSFC_wrapper.meta b/physics/module_MYJSFC_wrapper.meta index 1201fd56b..65ccc7dd9 100644 --- a/physics/module_MYJSFC_wrapper.meta +++ b/physics/module_MYJSFC_wrapper.meta @@ -23,9 +23,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 @@ -740,9 +740,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 diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 25dc89efe..d1a74fdb9 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -30,9 +30,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 @@ -1281,9 +1281,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 diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index 39a05f858..ef5025886 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -23,9 +23,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 @@ -850,9 +850,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 diff --git a/physics/module_SGSCloud_RadPost.meta b/physics/module_SGSCloud_RadPost.meta index 7298426ae..d9000a91f 100644 --- a/physics/module_SGSCloud_RadPost.meta +++ b/physics/module_SGSCloud_RadPost.meta @@ -76,9 +76,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 diff --git a/physics/module_SGSCloud_RadPre.meta b/physics/module_SGSCloud_RadPre.meta index 14c3127fc..c135a4925 100644 --- a/physics/module_SGSCloud_RadPre.meta +++ b/physics/module_SGSCloud_RadPre.meta @@ -347,9 +347,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 diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index 1bb6847eb..c2d873065 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -31,9 +31,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 @@ -583,9 +583,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 diff --git a/physics/moninshoc.meta b/physics/moninshoc.meta index ab4103891..f01b2c58d 100644 --- a/physics/moninshoc.meta +++ b/physics/moninshoc.meta @@ -23,9 +23,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 @@ -522,9 +522,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 diff --git a/physics/mp_fer_hires.meta b/physics/mp_fer_hires.meta index 08c6d939a..9f7c63d4d 100644 --- a/physics/mp_fer_hires.meta +++ b/physics/mp_fer_hires.meta @@ -87,9 +87,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 @@ -106,9 +106,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 @@ -336,9 +336,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 diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 248b76cc9..efd44e2ff 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -268,9 +268,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 @@ -647,9 +647,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 @@ -667,9 +667,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 diff --git a/physics/mp_thompson_post.meta b/physics/mp_thompson_post.meta index 5107bf642..82b035e99 100644 --- a/physics/mp_thompson_post.meta +++ b/physics/mp_thompson_post.meta @@ -24,9 +24,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 @@ -126,9 +126,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 @@ -146,9 +146,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 diff --git a/physics/mp_thompson_pre.meta b/physics/mp_thompson_pre.meta index c21dd6001..12e812bb3 100644 --- a/physics/mp_thompson_pre.meta +++ b/physics/mp_thompson_pre.meta @@ -46,9 +46,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 diff --git a/physics/ozphys.meta b/physics/ozphys.meta index 5d6a9fff7..485e2a491 100644 --- a/physics/ozphys.meta +++ b/physics/ozphys.meta @@ -23,9 +23,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 @@ -200,9 +200,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 diff --git a/physics/ozphys_2015.meta b/physics/ozphys_2015.meta index 070e57e54..8bce7defe 100644 --- a/physics/ozphys_2015.meta +++ b/physics/ozphys_2015.meta @@ -23,9 +23,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 @@ -199,9 +199,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 diff --git a/physics/phys_tend.meta b/physics/phys_tend.meta index ffb9c0b12..0f78af20b 100644 --- a/physics/phys_tend.meta +++ b/physics/phys_tend.meta @@ -87,9 +87,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 diff --git a/physics/precpd.meta b/physics/precpd.meta index 1b9cb30b6..67f1a530b 100644 --- a/physics/precpd.meta +++ b/physics/precpd.meta @@ -37,9 +37,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 @@ -261,9 +261,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 diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index d96ab9af1..df1a368c5 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -352,9 +352,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 diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index 632dc3912..70bc136f3 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -413,9 +413,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 diff --git a/physics/rascnv.meta b/physics/rascnv.meta index f4563ea89..9ace89287 100644 --- a/physics/rascnv.meta +++ b/physics/rascnv.meta @@ -143,9 +143,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 @@ -163,9 +163,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 @@ -615,9 +615,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 diff --git a/physics/rayleigh_damp.meta b/physics/rayleigh_damp.meta index 568cb9486..63025bcff 100644 --- a/physics/rayleigh_damp.meta +++ b/physics/rayleigh_damp.meta @@ -183,9 +183,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 diff --git a/physics/rrtmg_lw_post.meta b/physics/rrtmg_lw_post.meta index e2731faab..fc52ff901 100644 --- a/physics/rrtmg_lw_post.meta +++ b/physics/rrtmg_lw_post.meta @@ -128,9 +128,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 diff --git a/physics/rrtmg_lw_pre.meta b/physics/rrtmg_lw_pre.meta index affc45384..9f6ec07c8 100644 --- a/physics/rrtmg_lw_pre.meta +++ b/physics/rrtmg_lw_pre.meta @@ -16,9 +16,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 diff --git a/physics/rrtmg_sw_post.meta b/physics/rrtmg_sw_post.meta index 819090937..fb9c6dbf2 100644 --- a/physics/rrtmg_sw_post.meta +++ b/physics/rrtmg_sw_post.meta @@ -244,9 +244,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 diff --git a/physics/rrtmg_sw_pre.meta b/physics/rrtmg_sw_pre.meta index f980c6a3d..6a3a4e0a4 100644 --- a/physics/rrtmg_sw_pre.meta +++ b/physics/rrtmg_sw_pre.meta @@ -52,9 +52,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 diff --git a/physics/rrtmgp_lw_aerosol_optics.meta b/physics/rrtmgp_lw_aerosol_optics.meta index 875143df1..165051409 100644 --- a/physics/rrtmgp_lw_aerosol_optics.meta +++ b/physics/rrtmgp_lw_aerosol_optics.meta @@ -145,9 +145,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 diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index 4617912cc..35e27979e 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -81,9 +81,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 @@ -297,9 +297,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 diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta index 2571e7295..2e4029ae2 100644 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ b/physics/rrtmgp_lw_cloud_sampling.meta @@ -167,9 +167,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 diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta index 2024df664..0b484b6ac 100644 --- a/physics/rrtmgp_lw_gas_optics.meta +++ b/physics/rrtmgp_lw_gas_optics.meta @@ -93,9 +93,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 @@ -195,9 +195,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 diff --git a/physics/rrtmgp_lw_pre.meta b/physics/rrtmgp_lw_pre.meta index 8a8b15467..aa2a06a0f 100644 --- a/physics/rrtmgp_lw_pre.meta +++ b/physics/rrtmgp_lw_pre.meta @@ -39,9 +39,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 diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 752251c43..069537964 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -165,9 +165,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 diff --git a/physics/rrtmgp_sw_aerosol_optics.meta b/physics/rrtmgp_sw_aerosol_optics.meta index f56a54467..2abacd92a 100644 --- a/physics/rrtmgp_sw_aerosol_optics.meta +++ b/physics/rrtmgp_sw_aerosol_optics.meta @@ -160,9 +160,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 diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta index 4856d44d5..d73258cb2 100644 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ b/physics/rrtmgp_sw_cloud_optics.meta @@ -81,9 +81,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 @@ -279,9 +279,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 diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta index 23f8fa031..cda161e81 100644 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ b/physics/rrtmgp_sw_cloud_sampling.meta @@ -174,9 +174,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 diff --git a/physics/rrtmgp_sw_gas_optics.meta b/physics/rrtmgp_sw_gas_optics.meta index 5bcfe6cb2..1fdbc946b 100644 --- a/physics/rrtmgp_sw_gas_optics.meta +++ b/physics/rrtmgp_sw_gas_optics.meta @@ -61,9 +61,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 @@ -186,9 +186,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 diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index 995a5626a..e59698c0f 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -197,9 +197,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 diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index d38203465..baf01fb8e 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -30,9 +30,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 @@ -600,9 +600,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 diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index cdc61c1a3..d768d4451 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -30,9 +30,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 @@ -422,9 +422,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 diff --git a/physics/sascnvn.meta b/physics/sascnvn.meta index 082b87d09..66e5161ad 100644 --- a/physics/sascnvn.meta +++ b/physics/sascnvn.meta @@ -30,9 +30,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 @@ -504,9 +504,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 diff --git a/physics/satmedmfvdif.meta b/physics/satmedmfvdif.meta index 9eff692d8..3609ed50f 100644 --- a/physics/satmedmfvdif.meta +++ b/physics/satmedmfvdif.meta @@ -38,9 +38,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 @@ -576,9 +576,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 diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index d6fb95715..db89f488d 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -37,9 +37,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 @@ -646,9 +646,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 diff --git a/physics/scm_sfc_flux_spec.meta b/physics/scm_sfc_flux_spec.meta index 9ff2f15c4..46bb10897 100644 --- a/physics/scm_sfc_flux_spec.meta +++ b/physics/scm_sfc_flux_spec.meta @@ -23,9 +23,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 @@ -307,9 +307,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 diff --git a/physics/sfc_cice.meta b/physics/sfc_cice.meta index fd259111a..796fb2f5d 100644 --- a/physics/sfc_cice.meta +++ b/physics/sfc_cice.meta @@ -236,9 +236,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 diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index d19a62542..dd3bf79b8 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -206,9 +206,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 diff --git a/physics/sfc_diag_post.meta b/physics/sfc_diag_post.meta index 21d76a147..873dd671e 100644 --- a/physics/sfc_diag_post.meta +++ b/physics/sfc_diag_post.meta @@ -179,9 +179,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 diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 86268392d..a2e1fe9f7 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -574,9 +574,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 diff --git a/physics/sfc_drv.meta b/physics/sfc_drv.meta index 6463a3ed7..a3aa9044e 100644 --- a/physics/sfc_drv.meta +++ b/physics/sfc_drv.meta @@ -74,9 +74,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 @@ -94,9 +94,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 @@ -743,9 +743,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 diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 30c05b81f..d8443f0bd 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -504,9 +504,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 @@ -524,9 +524,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 @@ -1596,9 +1596,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 diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index e37036c32..ea08e6bf7 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -74,9 +74,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 @@ -1263,9 +1263,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 diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index 7d5fcfca5..d80ebf0cf 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -611,9 +611,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 @@ -745,9 +745,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 @@ -938,9 +938,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 diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index 85a891644..e99ad39fc 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -259,9 +259,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 diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index c2a215a03..718109879 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -432,9 +432,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 diff --git a/physics/shalcnv.meta b/physics/shalcnv.meta index 0f91a043a..f554201c5 100644 --- a/physics/shalcnv.meta +++ b/physics/shalcnv.meta @@ -44,9 +44,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 @@ -400,9 +400,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 diff --git a/physics/shinhongvdif.meta b/physics/shinhongvdif.meta index 8d0dac7db..dcd3b96cd 100644 --- a/physics/shinhongvdif.meta +++ b/physics/shinhongvdif.meta @@ -23,9 +23,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 @@ -488,9 +488,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 diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta index 553433765..4865f5a6a 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/ugwpv1_gsldrag.meta @@ -248,9 +248,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 @@ -268,9 +268,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 @@ -1091,9 +1091,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 diff --git a/physics/ugwpv1_gsldrag_post.meta b/physics/ugwpv1_gsldrag_post.meta index 2021fdb42..4a0e88de9 100644 --- a/physics/ugwpv1_gsldrag_post.meta +++ b/physics/ugwpv1_gsldrag_post.meta @@ -269,9 +269,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 diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index b3f7a4d75..cf6350f58 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -227,9 +227,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 @@ -261,9 +261,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 @@ -1187,9 +1187,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 diff --git a/physics/unified_ugwp_post.meta b/physics/unified_ugwp_post.meta index e2723821b..1df5cc5b5 100644 --- a/physics/unified_ugwp_post.meta +++ b/physics/unified_ugwp_post.meta @@ -269,9 +269,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 diff --git a/physics/ysuvdif.meta b/physics/ysuvdif.meta index f28ef3eff..0007197bd 100644 --- a/physics/ysuvdif.meta +++ b/physics/ysuvdif.meta @@ -23,9 +23,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 @@ -511,9 +511,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 f685e2011fa14017571bc51540789e0c7932d21c Mon Sep 17 00:00:00 2001 From: jeff beck Date: Tue, 18 Jan 2022 20:47:55 +0000 Subject: [PATCH 091/212] Fix varmax field dimensions --- physics/drag_suite.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 919484e87..31fb4fd50 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -606,8 +606,8 @@ subroutine drag_suite_run( & do i = its,im var_stoch(i) = var(i) + var(i)*0.75*spp_wts_gwd(i,1) varss_stoch(i) = varss(i) + varss(i)*0.75*spp_wts_gwd(i,1) - varmax_ss_stoch(i) = varmax_ss + varmax_ss*0.75*spp_wts_gwd(i,1) - varmax_fd_stoch(i) = varmax_fd + varmax_fd*0.75*spp_wts_gwd(i,1) + varmax_ss_stoch = varmax_ss + varmax_ss*0.75*spp_wts_gwd(i,1) + varmax_fd_stoch = varmax_fd + varmax_fd*0.75*spp_wts_gwd(i,1) enddo else var_stoch = var @@ -1001,8 +1001,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))) + var_temp = MIN(varss_stoch(i),varmax_ss_stoch) + & + MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch)) ! 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) @@ -1016,8 +1016,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))) + var_temp = MIN(varss_stoch(i),varmax_ss_stoch) + & + MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch)) ! 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) @@ -1081,8 +1081,8 @@ 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(varss_stoch(i),varmax_fd_stoch) + & + MAX(0.,beta_fd*(varss_stoch(i)-varmax_fd_stoch)) var_temp = MIN(var_temp, 250.) a1=0.00026615161*var_temp**2 ! a1=0.00026615161*MIN(varss(i),varmax)**2 From 57d75336218836fe653fb5a750b6e91486d55f99 Mon Sep 17 00:00:00 2001 From: Michael Iacono Date: Tue, 18 Jan 2022 21:45:59 +0000 Subject: [PATCH 092/212] Revisions to repair iovr=5 cloud overlap option --- physics/radiation_clouds.f | 185 ++++++++++++++++++++++++++++++------- physics/radlw_main.F90 | 54 +++++------ physics/radsw_main.F90 | 8 +- 3 files changed, 187 insertions(+), 60 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 90b7460a0..b4a8be627 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -876,6 +876,19 @@ subroutine progcld1 & 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 @@ -1272,6 +1285,19 @@ subroutine progcld2 & 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. @@ -1699,6 +1725,19 @@ subroutine progcld3 & 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. @@ -2062,6 +2101,19 @@ subroutine progcld4 & 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 @@ -2416,6 +2468,19 @@ subroutine progcld4o & 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 @@ -2792,6 +2857,19 @@ subroutine progcld5 & 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. @@ -3128,8 +3206,7 @@ subroutine progcld6 & enddo enddo - ! What portion of water and ice contents is associated with the - ! partly cloudy boxes + ! What portion of water and ice contents is associated with the partly cloudy boxes do i = 1, IX do k = 1, NLAY-1 if (cldtot(i,k).ge.climit .and. cldtot(i,k).lt.ovcst) then @@ -3188,6 +3265,19 @@ subroutine progcld6 & 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. @@ -3274,7 +3364,7 @@ subroutine progcld_thompson & ! 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) ! -! gridkm (IX) : grid length in km ! +! gridkm : grid length in km ! ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! ! uni_cld : logical - true for cloud fraction from shoc ! @@ -3333,8 +3423,8 @@ 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 + real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), intent(in) :: julian, gridkm integer, intent(in) :: yearlen ! --- outputs @@ -3408,14 +3498,14 @@ subroutine progcld_thompson & 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 +!> - Since using Thompson MP, assume 20 percent of snow is actually in !! ice sizes. do k = 1, NLAY-1 do i = 1, IX cwp(i,k) = max(0.0, clw(i,k,ntcw) * dz(i,k)*1.E6) crp(i,k) = 0.0 - snow_mass_factor = 0.99 + snow_mass_factor = 0.85 cip(i,k) = max(0.0, (clw(i,k,ntiw) & & + (1.0-snow_mass_factor)*clw(i,k,ntsw))*dz(i,k)*1.E6) if (re_snow(i,k) .gt. snow_max_radius)then @@ -3481,7 +3571,7 @@ subroutine progcld_thompson & endif call cal_cldfra3(cldfra1d, qv1d, qc1d, qi1d, qs1d, dz1d, & - & p1d, t1d, xland, gridkm(i), & + & p1d, t1d, xland, gridkm, & & .false., max_relh, 1, nlay, .false.) do k = 1, NLAY @@ -3555,6 +3645,19 @@ subroutine progcld_thompson & 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. @@ -3952,6 +4055,19 @@ subroutine progclduni & 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. @@ -4495,16 +4611,16 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & DO k = kts,kte delz = MAX(100., dz(k)) - RH_00L = 0.77+MIN(0.22,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) - RH_00O = 0.85+MIN(0.14,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00L = 0.74+MIN(0.25,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00O = 0.82+MIN(0.17,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) RHUM = rh(k) - if (qc(k).ge.1.E-6 .or. qi(k).ge.1.E-7 & - & .or. (qs(k).gt.1.E-6 .and. t(k).lt.273.)) then + if (qc(k).ge.1.E-5 .or. qi(k).ge.1.E-5 & + & .or. (qs(k).gt.1.E-5 .and. t(k).lt.273.)) then CLDFRA(K) = 1.0 elseif (((qc(k)+qi(k)).gt.1.E-10) .and. & - & ((qc(k)+qi(k)).lt.1.E-6)) then - CLDFRA(K) = MIN(0.99, 0.1*(11.0 + log10(qc(k)+qi(k)))) + & ((qc(k)+qi(k)).lt.1.E-5)) then + CLDFRA(K) = MIN(0.99, 0.20*(10.0 + log10(qc(k)+qi(k)))) else IF ((XLAND-1.5).GT.0.) THEN !--- Ocean @@ -4513,7 +4629,7 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & RH_00 = RH_00L ENDIF - tc = MAX(-80.0, t(k) - 273.15) + tc = t(k) - 273.15 if (tc .lt. -12.0) RH_00 = RH_00L if (tc .gt. 20.0) then @@ -4525,12 +4641,12 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & if (max_relh.gt.1.12 .or. (.NOT.(modify_qvapor)) ) then !..For HRRR model, the following look OK. RHUM = MIN(rh(k), 1.45) - RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+85.) + RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+112.) CLDFRA(K) = MAX(0.,1.0-SQRT((1.46-RHUM)/(1.46-RH_00))) else !..but for the GFS model, RH is way lower. RHUM = MIN(rh(k), 1.05) - RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+85.) + RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+112.) CLDFRA(K) = MAX(0.,1.0-SQRT((1.06-RHUM)/(1.06-RH_00))) endif endif @@ -4548,6 +4664,15 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & call adjust_cloudFinal(cldfra, qc, qi, rhoa, dz, kts,kte) + if (debug_flag .and. ndebug.lt.25) then + do k = kts,kte + write(6,'(a,i3,f9.2,f7.1,f7.2,f6.1,f6.3,f12.7,f12.7,f12.7)') & + & ' DEBUG-GT: ', k, p(k)*0.01, dz(k), t(k)-273.15, & + & rh(k)*100., cldfra(k), qc(k)*1.E3, qi(k)*1.E3, qs(k)*1.E3 + enddo + ndebug = ndebug + 1 + endif + !..Intended for cold start model runs, we use modify_qvapor to ensure that cloudy !.. areas are actually saturated such that the inserted clouds do not evaporate a !.. timestep later. @@ -4689,9 +4814,9 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, entrmnt,& k = k - 1 ENDDO - k_cldb = k_m12C + 3 + k_cldb = k_m12C + 5 in_cloud = .false. - k = k_m12C + 2 + k = k_m12C + 4 DO WHILE (.not. in_cloud .AND. k.gt.kbot) k_cldt = 0 if (cfr1d(k).ge.0.01) then @@ -4740,13 +4865,12 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) do k = k1, k2 tdz = tdz + dz(k) enddo -! max_iwc = ABS(qvs(k2)-qvs(k1)) - max_iwc = MAX(0.0, qvs(k1)-qvs(k2)) + max_iwc = ABS(qvs(k2)-qvs(k1)) do k = k1, k2 - max_iwc = MAX(1.E-6, max_iwc - (qi(k)+qs(k))) + max_iwc = MAX(1.E-5, max_iwc - (qi(k)+qs(k))) enddo - max_iwc = MIN(1.E-4, max_iwc) + max_iwc = MIN(2.E-3, max_iwc) this_dz = 0.0 do k = k1, k2 @@ -4756,7 +4880,7 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) this_dz = this_dz + dz(k) endif this_iwc = max_iwc*this_dz/tdz - iwc = MAX(1.E-6, this_iwc*(1.-entr)) + iwc = MAX(5.E-6, this_iwc*(1.-entr)) if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.203.16) then qi(k) = qi(k) + cfr(k)*cfr(k)*iwc endif @@ -4781,14 +4905,13 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) do k = k1, k2 tdz = tdz + dz(k) enddo -! max_lwc = ABS(qvs(k2)-qvs(k1)) - max_lwc = MAX(0.0, qvs(k1)-qvs(k2)) + max_lwc = ABS(qvs(k2)-qvs(k1)) ! print*, ' max_lwc = ', max_lwc, ' over DZ=',tdz do k = k1, k2 - max_lwc = MAX(1.E-6, max_lwc - qc(k)) + max_lwc = MAX(1.E-5, max_lwc - qc(k)) enddo - max_lwc = MIN(1.E-4, max_lwc) + max_lwc = MIN(2.E-3, max_lwc) this_dz = 0.0 do k = k1, k2 @@ -4798,8 +4921,8 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) this_dz = this_dz + dz(k) endif this_lwc = max_lwc*this_dz/tdz - lwc = MAX(1.E-6, this_lwc*(1.-entr)) - if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.258.16) then + lwc = MAX(5.E-6, this_lwc*(1.-entr)) + if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.253.16) then qc(k) = qc(k) + cfr(k)*cfr(k)*lwc endif enddo @@ -4851,6 +4974,6 @@ SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte) END SUBROUTINE adjust_cloudFinal !........................................! - end module module_radiation_clouds + end module module_radiation_clouds ! !! @} !========================================! diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 14a28cf6b..95bc0b059 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -1363,7 +1363,8 @@ subroutine rlwinit & ! =1: maximum/random overlapping clouds ! ! =2: maximum overlap cloud (isubcol>0 only) ! ! =3: decorrelation-length overlap (for isubclw>0 only) ! -! =4: exponential overlap cloud +! =4: exponential cloud overlap (AER) ! +! =5: exponential-random cloud overlap (AER) ! ! ! ! ******************************************************************* ! ! original code description ! @@ -1407,7 +1408,7 @@ subroutine rlwinit & ! !===> ... begin here ! - if ( iovr<0 .or. iovr>4 ) then + if ( iovr<0 .or. iovr>5 ) then print *,' *** Error in specification of cloud overlap flag', & & ' IOVR=',iovr,' in RLWINIT !!' stop @@ -1896,6 +1897,7 @@ subroutine mcica_subcol & ! other control flags from module variables: ! ! iovr : control flag for cloud overlapping method ! ! =0:random; =1:maximum/random: =2:maximum; =3:decorr ! +! =4:exponential; =5:exponential-random ! ! ! ! ===================== end of definitions ==================== ! @@ -2084,39 +2086,39 @@ subroutine mcica_subcol & ! --- setup 2 sets of random numbers -! call random_number ( rand2d, stat ) + call random_number ( rand2d, stat ) -! k1 = 0 -! do k = 1, nlay -! do n = 1, ngptlw -! k1 = k1 + 1 -! cdfunc(n,k) = rand2d(k1) -! enddo -! enddo + k1 = 0 + do k = 1, nlay + do n = 1, ngptlw + k1 = k1 + 1 + cdfunc(n,k) = rand2d(k1) + enddo + enddo -! call random_number ( rand2d, stat ) + call random_number ( rand2d, stat ) -! k1 = 0 -! do k = 1, nlay -! do n = 1, ngptlw -! k1 = k1 + 1 -! cdfun2(n,k) = rand2d(k1) -! enddo -! enddo + k1 = 0 + do k = 1, nlay + do n = 1, ngptlw + k1 = k1 + 1 + cdfun2(n,k) = rand2d(k1) + enddo + enddo ! --- then working upward from the surface: ! if a random number (from an independent set: cdfun2) is smaller than ! alpha, then use the previous layer's number, otherwise use a new random ! number (keep the originally assigned one in cdfunc for that layer). -! do k = 2, nlay -! k1 = k - 1 -! do n = 1, ngptlw -! if ( cdfun2(n,k) < alpha(k) ) then -! cdfunc(n,k) = cdfunc(n,k1) -! endif -! enddo -! enddo + do k = 2, nlay + k1 = k - 1 + do n = 1, ngptlw + if ( cdfun2(n,k) < alpha(k) ) then + cdfunc(n,k) = cdfunc(n,k1) + endif + enddo + enddo end select diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index 44de9848c..d09f586a3 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -1120,7 +1120,7 @@ subroutine rrtmg_sw_run & endif enddo zcf0 = zcf0 * zcf1 - else if (iovr >= 2 .and. iovr /= 4) then + else if (iovr >= 2) then do k = 1, nlay zcf0 = min ( zcf0, f_one-cfrac(k) ) ! used only as clear/cloudy indicator enddo @@ -1436,6 +1436,8 @@ subroutine rswinit & ! =1: maximum/random overlapping clouds ! ! =2: maximum overlap cloud ! ! =3: decorrelation-length overlap clouds ! +! =4: exponential cloud overlap (AER) ! +! =5: exponential-random cloud overlap (AER) ! ! iswmode - control flag for 2-stream transfer scheme ! ! =1; delta-eddington (joseph et al., 1976) ! ! =2: pifm (zdunkowski et al., 1980) ! @@ -1467,7 +1469,7 @@ subroutine rswinit & ! !===> ... begin here ! - if ( iovr<0 .or. iovr>4 ) then + if ( iovr<0 .or. iovr>5 ) then print *,' *** Error in specification of cloud overlap flag', & & ' IOVR=',iovr,' in RSWINIT !!' stop @@ -1935,7 +1937,7 @@ subroutine cldprop & !> -# if physparam::isubcsw > 0, call mcica_subcol() to distribute !! cloud properties to each g-point. - if ( isubcsw > 0 .and. iovr /= 4 ) then ! mcica sub-col clouds approx + if ( isubcsw > 0 ) then ! mcica sub-col clouds approx cldf(:) = cfrac(:) where (cldf(:) < ftiny) From f50f1f8758c6b41c874259aebdbf3be0155d1a8d Mon Sep 17 00:00:00 2001 From: Michael Iacono Date: Wed, 19 Jan 2022 18:14:49 +0000 Subject: [PATCH 093/212] add fix for unbalanced parenthses --- physics/radiation_clouds.f | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index b4a8be627..888087e56 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -882,7 +882,7 @@ subroutine progcld1 & 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 + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then alpha(i,k) = 0.0 endif enddo @@ -1291,7 +1291,7 @@ subroutine progcld2 & 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 + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then alpha(i,k) = 0.0 endif enddo @@ -1731,7 +1731,7 @@ subroutine progcld3 & 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 + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then alpha(i,k) = 0.0 endif enddo @@ -2107,7 +2107,7 @@ subroutine progcld4 & 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 + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then alpha(i,k) = 0.0 endif enddo @@ -2474,7 +2474,7 @@ subroutine progcld4o & 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 + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then alpha(i,k) = 0.0 endif enddo @@ -2863,7 +2863,7 @@ subroutine progcld5 & 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 + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then alpha(i,k) = 0.0 endif enddo @@ -3271,7 +3271,7 @@ subroutine progcld6 & 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 + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then alpha(i,k) = 0.0 endif enddo @@ -3651,7 +3651,7 @@ subroutine progcld_thompson & 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 + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then alpha(i,k) = 0.0 endif enddo @@ -4061,7 +4061,7 @@ subroutine progclduni & 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 + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then alpha(i,k) = 0.0 endif enddo From 73eb0f35b3ee2a47f821fe808c50c052207ca9fc Mon Sep 17 00:00:00 2001 From: jeff beck Date: Thu, 20 Jan 2022 04:25:34 +0000 Subject: [PATCH 094/212] Add dimensions to SPP variables --- drag_suite.F90 | 1381 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1381 insertions(+) create mode 100755 drag_suite.F90 diff --git a/drag_suite.F90 b/drag_suite.F90 new file mode 100755 index 000000000..7fea98b13 --- /dev/null +++ b/drag_suite.F90 @@ -0,0 +1,1381 @@ +!> \File drag_suite.F90 +!! This file is the parameterization of orographic gravity wave +!! drag, mountain blocking, and form drag. + +!> This module contains the CCPP-compliant orographic gravity wave dray scheme. + module drag_suite + + contains + + subroutine drag_suite_init(gwd_opt, errmsg, errflg) + + integer, intent(in) :: gwd_opt + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Consistency checks + if (gwd_opt/=3 .and. gwd_opt/=33) then + write(errmsg,'(*(a))') "Logic error: namelist choice of gravity wave & + & drag is different from drag_suite scheme" + errflg = 1 + return + end if + end subroutine drag_suite_init + +! \defgroup GFS_ogwd GFS Orographic Gravity Wave Drag +!> \defgroup gfs_drag_suite GFS drag_suite Main +!! \brief This subroutine includes orographic gravity wave drag, mountain +!! blocking, and form drag. +!! +!> The time tendencies of zonal and meridional wind are altered to +!! include the effect of mountain induced gravity wave drag from +!! subgrid scale orography including convective breaking, shear +!! breaking and the presence of critical levels. +!! +!> \section arg_table_drag_suite_run Argument Table +!! \htmlinclude drag_suite_run.html +!! +!> \section gen_drag_suite GFS Orographic GWD Scheme General Algorithm +!! -# Calculate subgrid mountain blocking +!! -# Calculate orographic wave drag +!! +!! The NWP model gravity wave drag (GWD) scheme in the GFS has two +!! main components: how the surface stress is computed, and then how +!! that stress is distributed over a vertical column where it may +!! interact with the models momentum. Each of these depends on the +!! large scale environmental atmospheric state and assumptions about +!! the sub-grid scale processes. In Alpert GWD (1987) based on linear, +!! two-dimensional non-rotating, stably stratified flow over a mountain ridge, +!! sub-grid scale gravity wave motions are assumed which propagate away +!! from the mountain. Described in Alpert (1987), the flux measured over +!! a "low level" vertically averaged layer, in the atmosphere defines a base +!! level flux. "Low level" was taken to be the first 1/3 of the troposphere +!! in the 1987 implementation. This choice was meant to encompass a thick +!! low layer for vertical averages of the environmental (large scale) flow +!! quantities. The vertical momentum flux or gravity wave stress in a +!! grid box due to a single mountain is given as in Pierrehumbert, (1987) (PH): +!! +!! \f$ \tau = \frac {\rho \: U^{3}\: G(F_{r})} {\Delta X \; N } \f$ +!! +!! emetic \f$ \Delta X \f$ is a grid increment, N is the Brunt Viasala frequency +!! +!! +!! \f$ N(\sigma) = \frac{-g \: \sigma \: +!! \frac{\partial\Theta}{\partial\sigma}}{\Theta \:R \:T} \f$ +!! +!! The environmental variables are calculated from a mass weighted vertical +!! average over a base layer. G(Fr) is a monotonically increasing +!! function of Froude number, +!! +!! \f$ F_{r} = \frac{N h^{'}}{U} \f$ +!! +!! where U is the wind speed calculated as a mass weighted vertical average in +!! the base layer, and h', is the vertical displacement caused by the orography +!! variance. An effective mountain length for the gravity wave processes, +!! +!! \f$ l^{*} = \frac{\Delta X}{m} \f$ +!! +!! where m is the number of mountains in a grid box, can then +!! be defined to obtain the form of the base level stress +!! +!! +!! \f$ \tau = \frac {\rho \: U^{3} \: G(F_{r})} {N \;l^{*}} \f$ +!! +!! giving the stress induced from the surface in a model grid box. +!! PH gives the form for the function G(Fr) as +!! +!! +!! \f$ G(F_{r}) = \bar{G}\frac{F^{2}_{r}}{F^{2}_{r}\: + \:a^{2}} \f$ +!! +!! Where \f$ \bar{G} \f$ is an order unity non-dimensional saturation +!! flux set to 1 and 'a' is a function of the mountain aspect ratio also +!!set to 1 in the 1987 implementation of the GFS GWD. Typical values of +!! U=10m/s, N=0.01 1/s, l*=100km, and a=1, gives a flux of 1 Pascal and +!! if this flux is made to go to zero linearly with height then the +!! decelerations would be about 10/m/s/day which is consistent with +!! observations in PH. +!! +!! +!! In Kim, Moorthi, Alpert's (1998, 2001) GWD currently in GFS operations, +!! the GWD scheme has the same physical basis as in Alpert (1987) with the addition +!! of enhancement factors for the amplitude, G, and mountain shape details +!! in G(Fr) to account for effects from the mountain blocking. A factor, +!! E m', is an enhancement factor on the stress in the Alpert '87 scheme. +!! The E ranges from no enhancement to an upper limit of 3, E=E(OA)[1-3], +!! and is a function of OA, the Orographic Asymmetry defined in KA (1995) as +!! +!! Orographic Asymmetry (OA) = \f$ \frac{ \bar{x} \; - \; +!! \sum\limits_{j=1}^{N_{b}} x_{j} \; n_{j} }{\sigma_{x}} \f$ +!! +!! where Nb is the total number of bottom blocks in the mountain barrier, +!! \f$ \sigma_{x} \f$ is the standard deviation of the horizontal distance defined by +!! +!! \f$ \sigma_{x} = \sqrt{ \frac{\sum\limits_{j=1}^{N_{b}} +!! \; (x_{j} \; - \; \bar{x} )^2}{N_{x}} } \f$ +!! +!! +!! where Nx is the number of grid intervals for the large scale domain being +!! considered. So the term, E(OA)m'/ \f$ \Delta X \f$ in Kim's scheme represents +!! a multiplier on G shown in Alpert's eq (1), where m' is the number of mountains +!! in a sub-grid scale box. Kim increased the complexity of m' making it a +!! function of the fractional area of the sub-grid mountain and the asymmetry +!! and convexity statistics which are found from running a gravity wave +!! model for a large number of cases: +!! +!! \f$ m^{'} = C_{m} \Delta X \left[ \frac{1 \; + \; +!! \sum\limits_{x} L_{h} }{\Delta X} \right]^{OA+1} \f$ +!! +!! Where, according to Kim, \f$ \sum \frac{L_{h}}{\Delta X} \f$ is +!! the fractional area covered by the subgrid-scale orography higher than +!! a critical height \f$ h_{c} = Fr_{c} U_{0}/N_{0} \f$ , over the +!! "low level" vertically averaged layer, for a grid box with the interval +!! \f$ \Delta X \f$. Each \f$ L_{n}\f$ is the width of a segment of +!! orography intersection at the critical height: +!! +!! \f$ Fr_{0} = \frac{N_{0} \; h^{'}}{U_{0}} \f$ +!! +!! \f$ G^{'}(OC,Fr_{0}) = \frac{Fr_{0}^{2}}{Fr_{0}^{2} \; + \; a^{2}} \f$ +!! +!! \f$ a^{2} = \frac{C_{G}}{OC} \f$ +!! +!! \f$ E(OA, Fr_{0}) = (OA \; + \; 2)^{\delta} \f$ and \f$ \delta +!! \; = \; \frac{C_{E} \; Fr_{0}}{Fr_{c}} \f$ where \f$ Fr_{c} \f$ +!! is as in Alpert. +!! +!! +!! This represents a closed scheme, somewhat empirical adjustments +!! to the original scheme to calculate the surface stress. +!! +!! Momentum is deposited by the sub-grid scale gravity waves break due +!! to the presence of convective mixing assumed to occur when the +!! minimum Richardson number: +!! +!! Orographic Convexity (OC) = \f$ \frac{ \sum\limits_{j=1}^{N_{x}} +!! \; (h_{j} \; - \; \bar{h})^4 }{N_{x} \;\sigma_{h}^4} \f$ , +!! and where \f$ \sigma_{h} = \sqrt{ \frac{\sum\limits_{j=1}^{N_{x}} +!! \; (h_{j} \; - \; \bar{h} )^2}{N_{x}} } \f$ +!! +!! This represents a closed scheme, somewhat empirical adjustments +!! to the original scheme to calculate the surface stress. +!! +!! Momentum is deposited by the sub-grid scale gravity waves break due +!! to the presence of convective mixing assumed to occur when +!! the minimum Richardson number: +!! +!! \f$ Ri_{m} = \frac{Ri(1 \; - \; Fr)}{(1 \; + \; \sqrt{Ri}Fr)^2} \f$ +!! +!! Is less than 1/4 Or if critical layers are encountered in a layer +!! the the momentum flux will vanish. The critical layer is defined +!! when the base layer wind becomes perpendicular to the environmental +!! wind. Otherwise, wave breaking occurs at a level where the amplification +!! of the wave causes the local Froude number or similarly a truncated +!! (first term of the) Scorer parameter, to be reduced below a critical +!! value by the saturation hypothesis (Lindzen,). This is done through +!! eq 1 which can be written as +!! +!! \f$ \tau = \rho U N k h^{'2} \f$ +!! +!! For small Froude number this is discretized in the vertical so at each +!! level the stress is reduced by ratio of the Froude or truncated Scorer +!! parameter, \f$ \frac{U^{2}}{N^{2}} = \frac{N \tau_{l-1}}{\rho U^{3} k} \f$ , +!! where the stress is from the layer below beginning with that found near +!! the surface. The respective change in momentum is applied in +!! that layer building up from below. +!! +!! An amplitude factor is part of the calibration of this scheme which is +!! a function of the model resolution and the vertical diffusion. This +!! is because the vertical diffusion and the GWD account encompass +!! similar physical processes. Thus, one needs to run the model over +!! and over for various amplitude factors for GWD and vertical diffusion. +!! +!! In addition, there is also mountain blocking from lift and frictional +!! forces. Improved integration between how the GWD is calculated and +!! the mountain blocking of wind flow around sub-grid scale orography +!! is underway at NCEP. The GFS already has convectively forced GWD +!! an independent process. The next step is to test +!! +!> \section det_drag_suite GFS Orographic GWD Scheme Detailed Algorithm +!> @{ + subroutine drag_suite_run( & + & IM,KM,dvdt,dudt,dtdt,U1,V1,T1,Q1,KPBL, & + & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,DELTIM,KDT, & + & var,oc1,oa4,ol4, & + & varss,oc1ss,oa4ss,ol4ss, & + & THETA,SIGMA,GAMMA,ELVMAX, & + & dtaux2d_ls,dtauy2d_ls,dtaux2d_bl,dtauy2d_bl, & + & dtaux2d_ss,dtauy2d_ss,dtaux2d_fd,dtauy2d_fd, & + & dusfc,dvsfc, & + & dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & + & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & + & slmsk,br1,hpbl, & + & g, cp, rd, rv, fv, pi, imx, cdmbgwd, me, master, & + & lprnt, ipr, rdxzb, dx, gwd_opt, & + & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & + & dtend, dtidx, index_of_process_orographic_gwd, & + & index_of_temperature, index_of_x_wind, & + & index_of_y_wind, ldiag3d, & + & spp_wts_gwd, spp_gwd, errmsg, errflg) + +! ******************************************************************** +! -----> I M P L E M E N T A T I O N V E R S I O N <---------- +! +! ----- This code ----- +!begin WRF code + +! this code handles the time tendencies of u v due to the effect of mountain +! induced gravity wave drag from sub-grid scale orography. this routine +! not only treats the traditional upper-level wave breaking due to mountain +! variance (alpert 1988), but also the enhanced lower-tropospheric wave +! breaking due to mountain convexity and asymmetry (kim and arakawa 1995). +! thus, in addition to the terrain height data in a model grid box, +! additional 10-2d topographic statistics files are needed, including +! orographic standard deviation (var), convexity (oc1), asymmetry (oa4) +! and ol (ol4). these data sets are prepared based on the 30 sec usgs orography +! hong (1999). the current scheme was implmented as in hong et al.(2008) +! +! Originally coded by song-you hong and young-joon kim and implemented by song-you hong +! +! program history log: +! 2014-10-01 Hyun-Joo Choi (from KIAPS) flow-blocking drag of kim and doyle +! with blocked height by dividing streamline theory +! 2017-04-06 Joseph Olson (from Gert-Jan Steeneveld) added small-scale +! orographic grabity wave drag: +! 2017-09-15 Joseph Olson, with some bug fixes from Michael Toy: added the +! topographic form drag of Beljaars et al. (2004, QJRMS) +! Activation of each component is done by specifying the integer-parameters +! (defined below) to 0: inactive or 1: active +! gwd_opt_ls = 0 or 1: large-scale +! gwd_opt_bl = 0 or 1: blocking drag +! gwd_opt_ss = 0 or 1: small-scale gravity wave drag +! gwd_opt_fd = 0 or 1: topographic form drag +! 2017-09-25 Michael Toy (from NCEP GFS model) added dissipation heating +! gsd_diss_ht_opt = 0: dissipation heating off +! gsd_diss_ht_opt = 1: dissipation heating on +! 2020-08-25 Michael Toy changed logic control for drag component selection +! for CCPP. +! Namelist options: +! do_gsl_drag_ls_bl - logical flag for large-scale GWD + blocking +! do_gsl_drag_ss - logical flag for small-scale GWD +! do_gsl_drag_tofd - logical flag for turbulent form drag +! Compile-time options (same as before): +! gwd_opt_ls = 0 or 1: large-scale GWD +! gwd_opt_bl = 0 or 1: blocking drag +! +! References: +! Hong et al. (2008), wea. and forecasting +! Kim and Doyle (2005), Q. J. R. Meteor. Soc. +! Kim and Arakawa (1995), j. atmos. sci. +! Alpert et al. (1988), NWP conference. +! Hong (1999), NCEP office note 424. +! Steeneveld et al (2008), JAMC +! Tsiringakis et al. (2017), Q. J. R. Meteor. Soc. +! Beljaars et al. (2004), Q. J. R. Meteor. Soc. +! +! notice : comparible or lower resolution orography files than model resolution +! are desirable in preprocess (wps) to prevent weakening of the drag +!------------------------------------------------------------------------------- +! +! input +! dudt (im,km) non-lin tendency for u wind component +! dvdt (im,km) non-lin tendency for v wind component +! u1(im,km) zonal wind / sqrt(rcl) m/sec at t0-dt +! v1(im,km) meridional wind / sqrt(rcl) m/sec at t0-dt +! t1(im,km) temperature deg k at t0-dt +! q1(im,km) specific humidity at t0-dt +! deltim time step secs +! del(km) positive increment of pressure across layer (pa) +! KPBL(IM) is the index of the top layer of the PBL +! ipr & lprnt for diagnostics +! +! output +! dudt, dvdt wind tendency due to gwdo +! dTdt +! +!------------------------------------------------------------------------------- + +!end wrf code +!----------------------------------------------------------------------C +! USE +! ROUTINE IS CALLED FROM CCPP (AFTER CALLING PBL SCHEMES) +! +! PURPOSE +! USING THE GWD PARAMETERIZATIONS OF PS-GLAS AND PH- +! GFDL TECHNIQUE. THE TIME TENDENCIES OF U V +! ARE ALTERED TO INCLUDE THE EFFECT OF MOUNTAIN INDUCED +! GRAVITY WAVE DRAG FROM SUB-GRID SCALE OROGRAPHY INCLUDING +! CONVECTIVE BREAKING, SHEAR BREAKING AND THE PRESENCE OF +! CRITICAL LEVELS +! +! +! ******************************************************************** + USE MACHINE , ONLY : kind_phys + implicit none + + ! Interface variables + integer, intent(in) :: im, km, imx, kdt, ipr, me, master + integer, intent(in) :: gwd_opt + logical, intent(in) :: lprnt + integer, intent(in) :: KPBL(:) + real(kind=kind_phys), intent(in) :: deltim, G, CP, RD, RV, cdmbgwd(:) + real(kind=kind_phys), intent(inout) :: dtend(:,:,:) + logical, intent(in) :: ldiag3d + integer, intent(in) :: dtidx(:,:), index_of_temperature, & + & index_of_process_orographic_gwd, index_of_x_wind, index_of_y_wind + + integer :: kpblmax + integer, parameter :: ims=1, kms=1, its=1, kts=1 + real(kind=kind_phys), intent(in) :: fv, pi + real(kind=kind_phys) :: rcl, cdmb + real(kind=kind_phys) :: g_inv + + real(kind=kind_phys), intent(inout) :: & + & dudt(:,:),dvdt(:,:), & + & dtdt(:,:) + real(kind=kind_phys), intent(out) :: rdxzb(:) + real(kind=kind_phys), intent(in) :: & + & u1(:,:),v1(:,:), & + & t1(:,:),q1(:,:), & + & PHII(:,:),prsl(:,:), & + & prslk(:,:),PHIL(:,:) + real(kind=kind_phys), intent(in) :: prsi(:,:), & + & del(:,:) + real(kind=kind_phys), intent(in) :: var(:),oc1(:), & + & oa4(:,:),ol4(:,:), & + & dx(:) + real(kind=kind_phys), intent(in) :: varss(:),oc1ss(:), & + & oa4ss(:,:),ol4ss(:,:) + real(kind=kind_phys), intent(in) :: THETA(:),SIGMA(:), & + & GAMMA(:),ELVMAX(:) + +! added for small-scale orographic wave drag + real(kind=kind_phys), dimension(im,km) :: utendwave,vtendwave,thx,thvx + real(kind=kind_phys), intent(in) :: br1(:), & + & hpbl(:), & + & slmsk(:) + real(kind=kind_phys), dimension(im) :: govrth,xland + !real(kind=kind_phys), dimension(im,km) :: dz2 + real(kind=kind_phys) :: tauwavex0,tauwavey0, & + & XNBV,density,tvcon,hpbl2 + integer :: kpbl2,kvar + !real(kind=kind_phys), dimension(im,km+1) :: zq ! = PHII/g + real(kind=kind_phys), dimension(im,km) :: zl ! = PHIL/g + +!SPP + real(kind=kind_phys), dimension(im) :: var_stoch, varss_stoch, & + varmax_ss_stoch, varmax_fd_stoch + real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) + integer, intent(in) :: spp_gwd + + real(kind=kind_phys), dimension(im) :: rstoch + +!Output: + real(kind=kind_phys), intent(out) :: & + & dusfc(:), dvsfc(:) +!Output (optional): + real(kind=kind_phys), intent(out) :: & + & dusfc_ls(:),dvsfc_ls(:), & + & dusfc_bl(:),dvsfc_bl(:), & + & dusfc_ss(:),dvsfc_ss(:), & + & dusfc_fd(:),dvsfc_fd(:) + real(kind=kind_phys), intent(out) :: & + & dtaux2d_ls(:,:),dtauy2d_ls(:,:), & + & dtaux2d_bl(:,:),dtauy2d_bl(:,:), & + & dtaux2d_ss(:,:),dtauy2d_ss(:,:), & + & dtaux2d_fd(:,:),dtauy2d_fd(:,:) + +!Misc arrays + real(kind=kind_phys), dimension(im,km) :: dtaux2d, dtauy2d + +!------------------------------------------------------------------------- +! Flags to regulate the activation of specific components of drag suite: +! Each component is tapered off automatically as a function of dx, so best to +! keep them activated (.true.). + logical, intent(in) :: & + do_gsl_drag_ls_bl, & ! large-scale gravity wave drag and blocking + do_gsl_drag_ss, & ! small-scale gravity wave drag (Steeneveld et al. 2008) + do_gsl_drag_tofd ! form drag (Beljaars et al. 2004, QJRMS) + +! Additional flags + integer, parameter :: & + gwd_opt_ls = 1, & ! large-scale gravity wave drag + gwd_opt_bl = 1, & ! blocking drag + gsd_diss_ht_opt = 0 + +! Parameters for bounding the scale-adaptive variability: +! Small-scale GWD + turbulent form drag + real(kind=kind_phys), parameter :: dxmin_ss = 1000., & + & dxmax_ss = 12000. ! min,max range of tapering (m) +! Large-scale GWD + blocking + real(kind=kind_phys), parameter :: dxmin_ls = 3000., & + & dxmax_ls = 13000. ! min,max range of tapering (m) + real(kind=kind_phys), dimension(im) :: ss_taper, ls_taper ! small- and large-scale tapering factors (-) +! +! Variables for limiting topographic standard deviation (var) + real(kind=kind_phys), parameter :: varmax_ss = 50., & + varmax_fd = 150., & + beta_ss = 0.1, & + beta_fd = 0.2 + real(kind=kind_phys) :: var_temp, var_temp2 + +! added Beljaars orographic form drag + real(kind=kind_phys), dimension(im,km) :: utendform,vtendform + real(kind=kind_phys) :: a1,a2,wsp + real(kind=kind_phys) :: H_efold + +! critical richardson number for wave breaking : ! larger drag with larger value + real(kind=kind_phys), parameter :: ric = 0.25 + real(kind=kind_phys), parameter :: dw2min = 1. + real(kind=kind_phys), parameter :: rimin = -100. + real(kind=kind_phys), parameter :: bnv2min = 1.0e-5 + real(kind=kind_phys), parameter :: efmin = 0.0 + real(kind=kind_phys), parameter :: efmax = 10.0 + real(kind=kind_phys), parameter :: xl = 4.0e4 + real(kind=kind_phys), parameter :: critac = 1.0e-5 + real(kind=kind_phys), parameter :: gmax = 1. + real(kind=kind_phys), parameter :: veleps = 1.0 + real(kind=kind_phys), parameter :: factop = 0.5 + real(kind=kind_phys), parameter :: frc = 1.0 + real(kind=kind_phys), parameter :: ce = 0.8 + real(kind=kind_phys), parameter :: cg = 0.5 + integer,parameter :: kpblmin = 2 + +! +! local variables +! + integer :: i,j,k,lcap,lcapp1,nwd,idir, & + klcap,kp1 +! + real(kind=kind_phys) :: rcs,csg,fdir,cleff,cleff_ss,cs, & + rcsks,wdir,ti,rdz,tem2,dw2,shr2, & + bvf2,rdelks,wtkbj,tem,gfobnv,hd,fro, & + rim,temc,tem1,efact,temv,dtaux,dtauy, & + dtauxb,dtauyb,eng0,eng1 +! + logical :: ldrag(im),icrilv(im), & + flag(im),kloop1(im) +! + real(kind=kind_phys) :: taub(im),taup(im,km+1), & + xn(im),yn(im), & + ubar(im),vbar(im), & + fr(im),ulow(im), & + rulow(im),bnv(im), & + oa(im),ol(im), & + oass(im),olss(im), & + roll(im),dtfac(im), & + brvf(im),xlinv(im), & + delks(im),delks1(im), & + bnv2(im,km),usqj(im,km), & + taud_ls(im,km),taud_bl(im,km), & + ro(im,km), & + vtk(im,km),vtj(im,km), & + zlowtop(im),velco(im,km-1), & + coefm(im),coefm_ss(im) +! + integer :: kbl(im),klowtop(im) + integer,parameter :: mdir=8 + !integer :: nwdir(mdir) + !data nwdir/6,7,5,8,2,3,1,4/ + integer, parameter :: nwdir(8) = (/6,7,5,8,2,3,1,4/) +! +! variables for flow-blocking drag +! + real(kind=kind_phys),parameter :: frmax = 10. + real(kind=kind_phys),parameter :: olmin = 1.0e-5 + real(kind=kind_phys),parameter :: odmin = 0.1 + real(kind=kind_phys),parameter :: odmax = 10. + real(kind=kind_phys),parameter :: erad = 6371.315e+3 + integer :: komax(im) + integer :: kblk + real(kind=kind_phys) :: cd + real(kind=kind_phys) :: zblk,tautem + real(kind=kind_phys) :: pe,ke + real(kind=kind_phys) :: delx,dely + real(kind=kind_phys) :: dxy4(im,4),dxy4p(im,4) + real(kind=kind_phys) :: dxy(im),dxyp(im) + real(kind=kind_phys) :: ol4p(4),olp(im),od(im) + real(kind=kind_phys) :: taufb(im,km+1) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: udtend, vdtend, Tdtend + + ! Calculate inverse of gravitational acceleration + g_inv = 1./G + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Initialize local variables + var_temp2 = 0. + udtend = -1 + vdtend = -1 + Tdtend = -1 + + if(ldiag3d) then + udtend = dtidx(index_of_x_wind,index_of_process_orographic_gwd) + vdtend = dtidx(index_of_y_wind,index_of_process_orographic_gwd) + Tdtend = dtidx(index_of_temperature,index_of_process_orographic_gwd) + endif + +!-------------------------------------------------------------------- +! SCALE-ADPTIVE PARAMETER FROM GFS GWD SCHEME +!-------------------------------------------------------------------- +! parameter (cdmb = 1.0) ! non-dim sub grid mtn drag Amp (*j*) +! 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) + if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) + +!>-# Orographic Gravity Wave Drag Section + kpblmax = km / 2 ! maximum pbl height : # of vertical levels / 2 +! +! Scale cleff between IM=384*2 and 192*2 for T126/T170 and T62 +! + if (imx > 0) then +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/384.0) +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 0.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192)/float(IMX/192) +! cleff = 1.0E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! + cleff = 0.5E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! hmhj for ndsl +! jw cleff = 0.1E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 2.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 2.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! + endif + if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) +!-------------------------------------------------------------------- +! END SCALE-ADPTIVE PARAMETER SECTION +!-------------------------------------------------------------------- +! +!---- constants +! + rcl = 1. + rcs = sqrt(rcl) + cs = 1. / sqrt(rcl) + csg = cs * g + lcap = km + lcapp1 = lcap + 1 + fdir = mdir / (2.0*pi) + + do i=1,im + if (slmsk(i)==1. .or. slmsk(i)==2.) then !sea/land/ice mask (=0/1/2) in FV3 + xland(i)=1.0 !but land/water = (1/2) in this module + else + xland(i)=2.0 + endif + RDXZB(i) = 0.0 + enddo + +!--- calculate scale-aware tapering factors +do i=1,im + if ( dx(i) .ge. dxmax_ls ) then + ls_taper(i) = 1. + else + if ( dx(i) .le. dxmin_ls) then + ls_taper(i) = 0. + else + ls_taper(i) = 0.5 * ( SIN(pi*(dx(i)-0.5*(dxmax_ls+dxmin_ls))/ & + (dxmax_ls-dxmin_ls)) + 1. ) + endif + 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 + +! SPP, if spp_gwd is 0, no perturbations are applied. +if ( spp_gwd==1 ) then + do i = its,im + var_stoch(i) = var(i) + var(i)*0.75*spp_wts_gwd(i,1) + varss_stoch(i) = varss(i) + varss(i)*0.75*spp_wts_gwd(i,1) + varmax_ss_stoch(i) = varmax_ss + varmax_ss*0.75*spp_wts_gwd(i,1) + varmax_fd_stoch(i) = varmax_fd + varmax_fd*0.75*spp_wts_gwd(i,1) + enddo +else + do i = its,im + var_stoch(i) = var(i) + varss_stoch(i) = varss(i) + varmax_ss_stoch(i) = varmax_ss + varmax_fd_stoch(i) = varmax_fd + enddo +endif + +!--- calculate length of grid for flow-blocking drag +! +do i=1,im + delx = dx(i) + dely = dx(i) + dxy4(i,1) = delx + dxy4(i,2) = dely + dxy4(i,3) = sqrt(delx*delx + dely*dely) + dxy4(i,4) = dxy4(i,3) + dxy4p(i,1) = dxy4(i,2) + dxy4p(i,2) = dxy4(i,1) + dxy4p(i,3) = dxy4(i,4) + dxy4p(i,4) = dxy4(i,3) +enddo +! +!-----initialize arrays +! + dtaux = 0.0 + dtauy = 0.0 + do i = its,im + klowtop(i) = 0 + kbl(i) = 0 + enddo +! + do i = its,im + xn(i) = 0.0 + yn(i) = 0.0 + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + taub (i) = 0.0 + oa(i) = 0.0 + ol(i) = 0.0 + oass(i) = 0.0 + olss(i) = 0.0 + ulow (i) = 0.0 + dtfac(i) = 1.0 + rstoch(i) = 0.0 + ldrag(i) = .false. + icrilv(i) = .false. + flag(i) = .true. + enddo + + do k = kts,km + do i = its,im + usqj(i,k) = 0.0 + bnv2(i,k) = 0.0 + vtj(i,k) = 0.0 + vtk(i,k) = 0.0 + taup(i,k) = 0.0 + taud_ls(i,k) = 0.0 + taud_bl(i,k) = 0.0 + dtaux2d(i,k) = 0.0 + dtauy2d(i,k) = 0.0 + enddo + enddo +! + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then + do i = its,im + dusfc_ls(i) = 0.0 + dvsfc_ls(i) = 0.0 + dusfc_bl(i) = 0.0 + dvsfc_bl(i) = 0.0 + dusfc_ss(i) = 0.0 + dvsfc_ss(i) = 0.0 + dusfc_fd(i) = 0.0 + dvsfc_fd(i) = 0.0 + enddo + do k = kts,km + do i = its,im + dtaux2d_ls(i,k)= 0.0 + dtauy2d_ls(i,k)= 0.0 + dtaux2d_bl(i,k)= 0.0 + dtauy2d_bl(i,k)= 0.0 + dtaux2d_ss(i,k)= 0.0 + dtauy2d_ss(i,k)= 0.0 + dtaux2d_fd(i,k)= 0.0 + dtauy2d_fd(i,k)= 0.0 + enddo + enddo + endif + + do i = its,im + taup(i,km+1) = 0.0 + xlinv(i) = 1.0/xl + dusfc(i) = 0.0 + dvsfc(i) = 0.0 + enddo +! +! initialize array for flow-blocking drag +! + taufb(1:im,1:km+1) = 0.0 + komax(1:im) = 0 +! + do k = kts,km + do i = its,im + vtj(i,k) = t1(i,k) * (1.+fv*q1(i,k)) + vtk(i,k) = vtj(i,k) / prslk(i,k) + ro(i,k) = 1./rd * prsl(i,k) / vtj(i,k) ! density kg/m**3 + enddo + enddo +! +! calculate mid-layer height (zl), interface height (zq), and layer depth (dz2). +! + !zq=0. + do k = kts,km + do i = its,im + !zq(i,k+1) = PHII(i,k+1)*g_inv + !dz2(i,k) = (PHII(i,k+1)-PHII(i,k))*g_inv + zl(i,k) = PHIL(i,k)*g_inv + enddo + enddo +! +! determine reference level: maximum of 2*var and pbl heights +! + do i = its,im + zlowtop(i) = 2. * var_stoch(i) + enddo +! + do i = its,im + kloop1(i) = .true. + enddo +! + do k = kts+1,km + do i = its,im + if(kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then + klowtop(i) = k+1 + kloop1(i) = .false. + endif + enddo + enddo +! + do i = its,im + kbl(i) = max(kpbl(i), klowtop(i)) + kbl(i) = max(min(kbl(i),kpblmax),kpblmin) + enddo +! +! determine the level of maximum orographic height +! + ! komax(:) = kbl(:) + komax(:) = klowtop(:) - 1 ! modification by NOAA/GSD March 2018 +! + do i = its,im + delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) + delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) + enddo +! +! compute low level averages within pbl +! + do k = kts,kpblmax + do i = its,im + if (k.lt.kbl(i)) then + rcsks = rcs * del(i,k) * delks(i) + rdelks = del(i,k) * delks(i) + ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean + vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean + roll(i) = roll(i) + rdelks * ro(i,k) ! ro mean + endif + enddo + enddo +! +! figure out low-level horizontal wind direction +! +! nwd 1 2 3 4 5 6 7 8 +! wd w s sw nw e n ne se +! + do i = its,im + wdir = atan2(ubar(i),vbar(i)) + pi + idir = mod(nint(fdir*wdir),mdir) + 1 + nwd = nwdir(idir) + oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) + ol(i) = ol4(i,mod(nwd-1,4)+1) + ! Repeat for small-scale gwd + oass(i) = (1-2*int( (nwd-1)/4 )) * oa4ss(i,mod(nwd-1,4)+1) + olss(i) = ol4ss(i,mod(nwd-1,4)+1) + +! +!----- compute orographic width along (ol) and perpendicular (olp) +!----- the direction of wind +! + ol4p(1) = ol4(i,2) + ol4p(2) = ol4(i,1) + ol4p(3) = ol4(i,4) + ol4p(4) = ol4(i,3) + olp(i) = ol4p(mod(nwd-1,4)+1) +! +!----- compute orographic direction (horizontal orographic aspect ratio) +! + od(i) = olp(i)/max(ol(i),olmin) + od(i) = min(od(i),odmax) + od(i) = max(od(i),odmin) +! +!----- compute length of grid in the along(dxy) and cross(dxyp) wind directions +! + dxy(i) = dxy4(i,MOD(nwd-1,4)+1) + dxyp(i) = dxy4p(i,MOD(nwd-1,4)+1) + enddo +! +! END INITIALIZATION; BEGIN GWD CALCULATIONS: +! +IF ( (do_gsl_drag_ls_bl).and. & + ((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)) ) then + + do i=its,im + + if ( ls_taper(i).GT.1.E-02 ) then + +! +!--- saving richardson number in usqj for migwdi +! + do k = kts,km-1 + ti = 2.0 / (t1(i,k)+t1(i,k+1)) + rdz = 1./(zl(i,k+1) - zl(i,k)) + tem1 = u1(i,k) - u1(i,k+1) + tem2 = v1(i,k) - v1(i,k+1) + dw2 = rcl*(tem1*tem1 + tem2*tem2) + shr2 = max(dw2,dw2min) * rdz * rdz + bvf2 = g*(g/cp+rdz*(vtj(i,k+1)-vtj(i,k))) * ti + usqj(i,k) = max(bvf2/shr2,rimin) + bnv2(i,k) = 2.0*g*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) + bnv2(i,k) = max( bnv2(i,k), bnv2min ) + enddo +! +!----compute the "low level" or 1/3 wind magnitude (m/s) +! + ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) + rulow(i) = 1./ulow(i) +! + do k = kts,km-1 + velco(i,k) = (0.5*rcs) * ((u1(i,k)+u1(i,k+1)) * ubar(i) & + + (v1(i,k)+v1(i,k+1)) * vbar(i)) + velco(i,k) = velco(i,k) * rulow(i) + if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then + velco(i,k) = veleps + endif + enddo +! +! no drag when critical level in the base layer +! + ldrag(i) = velco(i,1).le.0. +! +! no drag when velco.lt.0 +! + do k = kpblmin,kpblmax + if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0. + enddo +! +! no drag when bnv2.lt.0 +! + do k = kts,kpblmax + if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. bnv2(i,k).lt.0. + enddo +! +!-----the low level weighted average ri is stored in usqj(1,1; im) +!-----the low level weighted average n**2 is stored in bnv2(1,1; im) +!---- this is called bnvl2 in phys_gwd_alpert_sub not bnv2 +!---- rdelks (del(k)/delks) vert ave factor so we can * instead of / +! + wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) + bnv2(i,1) = wtkbj * bnv2(i,1) + usqj(i,1) = wtkbj * usqj(i,1) +! + do k = kpblmin,kpblmax + if (k .lt. kbl(i)) then + rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) + bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks + usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks + endif + enddo +! + ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 + ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 + ldrag(i) = ldrag(i) .or. var_stoch(i) .le. 0.0 +! +! set all ri low level values to the low level value +! + do k = kpblmin,kpblmax + if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) + enddo +! + if (.not.ldrag(i)) then + bnv(i) = sqrt( bnv2(i,1) ) + fr(i) = bnv(i) * rulow(i) * 2. * var_stoch(i) * od(i) + fr(i) = min(fr(i),frmax) + xn(i) = ubar(i) * rulow(i) + yn(i) = vbar(i) * rulow(i) + endif +! +! compute the base level stress and store it in taub +! calculate enhancement factor, number of mountains & aspect +! ratio const. use simplified relationship between standard +! deviation & critical hgt + + if (.not. ldrag(i)) then + efact = (oa(i) + 2.) ** (ce*fr(i)/frc) + efact = min( max(efact,efmin), efmax ) +!!!!!!! cleff (effective grid length) is highly tunable parameter +!!!!!!! the bigger (smaller) value produce weaker (stronger) wave drag +!WRF cleff = sqrt(dxy(i)**2. + dxyp(i)**2.) +!WRF cleff = 3. * max(dx(i),cleff) + coefm(i) = (1. + ol(i)) ** (oa(i)+1.) +!WRF xlinv(i) = coefm(i) / cleff + xlinv(i) = coefm(i) * cleff + tem = fr(i) * fr(i) * oc1(i) + gfobnv = gmax * tem / ((tem + cg)*bnv(i)) + if ( gwd_opt_ls .NE. 0 ) then + taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & + * ulow(i) * gfobnv * efact + else ! We've gotten what we need for the blocking scheme + taub(i) = 0.0 + end if + else + taub(i) = 0.0 + xn(i) = 0.0 + yn(i) = 0.0 + endif + + endif ! (ls_taper(i).GT.1.E-02) + + enddo ! do i=its,im + +ENDIF ! (do_gsl_drag_ls_bl).and.((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)) + +!========================================================= +! add small-scale wavedrag for stable boundary layer +!========================================================= + XNBV=0. + tauwavex0=0. + tauwavey0=0. + density=1.2 + utendwave=0. + vtendwave=0. +! +IF ( do_gsl_drag_ss ) THEN + + do i=its,im + + if ( ss_taper(i).GT.1.E-02 ) then + ! + ! calculating potential temperature + ! + do k = kts,km + thx(i,k) = t1(i,k)/prslk(i,k) + enddo + ! + do k = kts,km + tvcon = (1.+fv*q1(i,k)) + thvx(i,k) = thx(i,k)*tvcon + enddo + + hpbl2 = hpbl(i)+10. + kpbl2 = kpbl(i) + !kvar = MIN(kpbl, k-level of var) + kvar = 1 + do k=kts+1,MAX(kpbl(i),kts+1) +! IF (zl(i,k)>2.*var(i) .or. zl(i,k)>2*varmax) then + IF (zl(i,k)>300.) then + kpbl2 = k + IF (k == kpbl(i)) then + hpbl2 = hpbl(i)+10. + ELSE + hpbl2 = zl(i,k)+10. + ENDIF + exit + ENDIF + 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 +! 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 + !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)) + XNBV=sqrt(govrth(i)*(thvx(i,kpbl2)-thvx(i,kts))/hpbl2) +! + !if(abs(XNBV/u1(i,kpbl(i))).gt.xlinv(i))then + if(abs(XNBV/u1(i,kpbl2)).gt.xlinv(i))then + !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))) + ! 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) + tauwavex0=tauwavex0*ss_taper(i) + else + tauwavex0=0. + endif +! + !if(abs(XNBV/v1(i,kpbl(i))).gt.xlinv(i))then + if(abs(XNBV/v1(i,kpbl2)).gt.xlinv(i))then + !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))) + ! 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) + tauwavey0=tauwavey0*ss_taper(i) + else + tauwavey0=0. + endif + + do k=kts,kpbl(i) !MIN(kpbl2+1,km-1) +!original + !utendwave(i,k)=-1.*tauwavex0*2.*max((1.-zl(i,k)/hpbl(i)),0.)/hpbl(i) + !vtendwave(i,k)=-1.*tauwavey0*2.*max((1.-zl(i,k)/hpbl(i)),0.)/hpbl(i) +!new + utendwave(i,k)=-1.*tauwavex0*2.*max((1.-zl(i,k)/hpbl2),0.)/hpbl2 + vtendwave(i,k)=-1.*tauwavey0*2.*max((1.-zl(i,k)/hpbl2),0.)/hpbl2 +!mod-to be used in HRRRv3/RAPv4 + !utendwave(i,k)=-1.*tauwavex0 * max((1.-zl(i,k)/hpbl2),0.)**2 + !vtendwave(i,k)=-1.*tauwavey0 * max((1.-zl(i,k)/hpbl2),0.)**2 + enddo + endif + endif + + do k = kts,km + dudt(i,k) = dudt(i,k) + utendwave(i,k) + dvdt(i,k) = dvdt(i,k) + vtendwave(i,k) + dusfc(i) = dusfc(i) + utendwave(i,k) * del(i,k) + dvsfc(i) = dvsfc(i) + vtendwave(i,k) * del(i,k) + enddo + if(udtend>0) then + dtend(i,kts:km,udtend) = dtend(i,kts:km,udtend) + utendwave(i,kts:km)*deltim + endif + if(vdtend>0) then + dtend(i,kts:km,vdtend) = dtend(i,kts:km,vdtend) + vtendwave(i,kts:km)*deltim + endif + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then + do k = kts,km + dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) + dvsfc_ss(i) = dvsfc_ss(i) + vtendwave(i,k) * del(i,k) + dtaux2d_ss(i,k) = utendwave(i,k) + dtauy2d_ss(i,k) = vtendwave(i,k) + enddo + endif + + endif ! if (ss_taper(i).GT.1.E-02) + + enddo ! i=its,im + +ENDIF ! if (do_gsl_drag_ss) + +!================================================================ +! Topographic Form Drag from Beljaars et al. (2004, QJRMS, equ. 16): +!================================================================ +IF ( do_gsl_drag_tofd ) THEN + + do i=its,im + + if ( ss_taper(i).GT.1.E-02 ) then + + utendform=0. + vtendform=0. + + 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.) + 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.) + 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 + var_temp = 0.0759*EXP(-(zl(i,k)/H_efold)**1.5)*a2* & + zl(i,k)**(-1.2)*ss_taper(i) ! this is greater than zero + ! Note: This is a semi-implicit treatment of the time differencing + ! per Beljaars et al. (2004, QJRMS) + utendform(i,k) = - var_temp*wsp*u1(i,k)/(1. + var_temp*deltim*wsp) + vtendform(i,k) = - var_temp*wsp*v1(i,k)/(1. + var_temp*deltim*wsp) + !IF(zl(i,k) > 4000.) exit + ENDDO + ENDIF + + do k = kts,km + dudt(i,k) = dudt(i,k) + utendform(i,k) + dvdt(i,k) = dvdt(i,k) + vtendform(i,k) + dusfc(i) = dusfc(i) + utendform(i,k) * del(i,k) + dvsfc(i) = dvsfc(i) + vtendform(i,k) * del(i,k) + enddo + if(udtend>0) then + dtend(i,kts:km,udtend) = dtend(i,kts:km,udtend) + utendform(i,kts:km)*deltim + endif + if(vdtend>0) then + dtend(i,kts:km,vdtend) = dtend(i,kts:km,vdtend) + vtendform(i,kts:km)*deltim + endif + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then + do k = kts,km + dtaux2d_fd(i,k) = utendform(i,k) + dtauy2d_fd(i,k) = vtendform(i,k) + dusfc_fd(i) = dusfc_fd(i) + utendform(i,k) * del(i,k) + dvsfc_fd(i) = dvsfc_fd(i) + vtendform(i,k) * del(i,k) + enddo + endif + + endif ! if (ss_taper(i).GT.1.E-02) + + enddo ! i=its,im + +ENDIF ! if (do_gsl_drag_tofd) +!======================================================= +! More for the large-scale gwd component +IF ( (do_gsl_drag_ls_bl).and.(gwd_opt_ls .EQ. 1) ) THEN + + do i=its,im + + if ( ls_taper(i).GT.1.E-02 ) then + +! +! now compute vertical structure of the stress. + do k = kts,kpblmax + if (k .le. kbl(i)) taup(i,k) = taub(i) + enddo +! + do k = kpblmin, km-1 ! vertical level k loop! + kp1 = k + 1 +! +! unstablelayer if ri < ric +! unstable layer if upper air vel comp along surf vel <=0 (crit lay) +! at (u-c)=0. crit layer exists and bit vector should be set (.le.) +! + if (k .ge. kbl(i)) then + icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & + .or. (velco(i,k) .le. 0.0) + brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared + brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency + endif +! + if (k .ge. kbl(i) .and. (.not. ldrag(i))) then + if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then + temv = 1.0 / velco(i,k) + tem1 = coefm(i)/dxy(i)*(ro(i,kp1)+ro(i,k))*brvf(i)* & + velco(i,k)*0.5 + hd = sqrt(taup(i,k) / tem1) + fro = brvf(i) * hd * temv +! +! rim is the minimum-richardson number by shutts (1985) + tem2 = sqrt(usqj(i,k)) + tem = 1. + tem2 * fro + rim = usqj(i,k) * (1.-fro) / (tem * tem) +! +! check stability to employ the 'saturation hypothesis' +! of lindzen (1981) except at tropospheric downstream regions +! + if (rim .le. ric) then ! saturation hypothesis! + if ((oa(i) .le. 0.).or.(kp1 .ge. kpblmin )) then + temc = 2.0 + 1.0 / tem2 + hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) + taup(i,kp1) = tem1 * hd * hd + endif + else ! no wavebreaking! + taup(i,kp1) = taup(i,k) + endif + endif + endif + enddo +! + if(lcap.lt.km) then + do klcap = lcapp1,km + taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + enddo + endif + + endif ! if ( ls_taper(i).GT.1.E-02 ) + + enddo ! do i=its,im + +ENDIF ! (do_gsl_drag_ls_bl).and.(gwd_opt_ls .EQ. 1) +!=============================================================== +!COMPUTE BLOCKING COMPONENT +!=============================================================== +IF ( (do_gsl_drag_ls_bl) .and. (gwd_opt_bl .EQ. 1) ) THEN + + do i=its,im + + if ( ls_taper(i).GT.1.E-02 ) then + + if (.not.ldrag(i)) then +! +!------- determine the height of flow-blocking layer +! + kblk = 0 + pe = 0.0 + do k = km, kpblmin, -1 + if(kblk.eq.0 .and. k.le.komax(i)) then + pe = pe + bnv2(i,k)*(zl(i,komax(i))-zl(i,k))* & + del(i,k)/g/ro(i,k) + ke = 0.5*((rcs*u1(i,k))**2.+(rcs*v1(i,k))**2.) +! +!---------- apply flow-blocking drag when pe >= ke +! + if(pe.ge.ke) then + kblk = k + kblk = min(kblk,kbl(i)) + zblk = zl(i,kblk)-zl(i,kts) + RDXZB(i) = real(k,kind=kind_phys) + endif + endif + enddo + if(kblk.ne.0) then +! +!--------- compute flow-blocking stress +! + cd = max(2.0-1.0/od(i),0.0) + taufb(i,kts) = 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) + do k = kts+1, kblk + taufb(i,k) = taufb(i,k-1) - tautem + enddo +! +!----------sum orographic GW stress and flow-blocking stress +! + ! taup(i,:) = taup(i,:) + taufb(i,:) ! Keep taup and taufb separate for now + endif + + endif ! if (.not.ldrag(i)) + + endif ! if ( ls_taper(i).GT.1.E-02 ) + + enddo ! do i=its,im + +ENDIF ! IF ( (do_gsl_drag_ls_bl) .and. (gwd_opt_bl .EQ. 1) ) +!=========================================================== +IF ( (do_gsl_drag_ls_bl) .and. & + (gwd_opt_ls .EQ. 1 .OR. gwd_opt_bl .EQ. 1) ) THEN + + do i=its,im + + if ( ls_taper(i) .GT. 1.E-02 ) then + +! +! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy +! + do k = kts,km + taud_ls(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) + taud_bl(i,k) = 1. * (taufb(i,k+1) - taufb(i,k)) * csg / del(i,k) + enddo +! +! limit de-acceleration (momentum deposition ) at top to 1/2 value +! the idea is some stuff must go out the 'top' + do klcap = lcap,km + taud_ls(i,klcap) = taud_ls(i,klcap) * factop + taud_bl(i,klcap) = taud_bl(i,klcap) * factop + enddo +! +! if the gravity wave drag would force a critical line +! in the lower ksmm1 layers during the next deltim timestep, +! then only apply drag until that critical line is reached. +! + do k = kts,kpblmax-1 + if (k .le. kbl(i)) then + if ((taud_ls(i,k)+taud_bl(i,k)).ne.0.) & + dtfac(i) = min(dtfac(i),abs(velco(i,k) & + /(deltim*rcs*(taud_ls(i,k)+taud_bl(i,k))))) + endif + enddo +! + do k = kts,km + taud_ls(i,k) = taud_ls(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i)) + taud_bl(i,k) = taud_bl(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i)) + + dtaux = taud_ls(i,k) * xn(i) + dtauy = taud_ls(i,k) * yn(i) + dtauxb = taud_bl(i,k) * xn(i) + dtauyb = taud_bl(i,k) * yn(i) + + !add blocking and large-scale contributions to tendencies + dudt(i,k) = dtaux + dtauxb + dudt(i,k) + dvdt(i,k) = dtauy + dtauyb + dvdt(i,k) + + if ( gsd_diss_ht_opt .EQ. 1 ) then + ! Calculate dissipation heating + ! Initial kinetic energy (at t0-dt) + eng0 = 0.5*( (rcs*u1(i,k))**2. + (rcs*v1(i,k))**2. ) + ! Kinetic energy after wave-breaking/flow-blocking + eng1 = 0.5*( (rcs*(u1(i,k)+(dtaux+dtauxb)*deltim))**2 + & + (rcs*(v1(i,k)+(dtauy+dtauyb)*deltim))**2 ) + ! Modify theta tendency + dtdt(i,k) = dtdt(i,k) + max((eng0-eng1),0.0)/cp/deltim + if ( Tdtend>0 ) then + dtend(i,k,Tdtend) = dtend(i,k,Tdtend) + max((eng0-eng1),0.0)/cp + endif + endif + + dusfc(i) = dusfc(i) + taud_ls(i,k)*xn(i)*del(i,k) + & + taud_bl(i,k)*xn(i)*del(i,k) + dvsfc(i) = dvsfc(i) + taud_ls(i,k)*yn(i)*del(i,k) + & + taud_bl(i,k)*yn(i)*del(i,k) + if(udtend>0) then + dtend(i,k,udtend) = dtend(i,k,udtend) + (taud_ls(i,k) * & + xn(i) + taud_bl(i,k) * xn(i)) * deltim + endif + if(vdtend>0) then + dtend(i,k,vdtend) = dtend(i,k,vdtend) + (taud_ls(i,k) * & + yn(i) + taud_bl(i,k) * yn(i)) * deltim + endif + + enddo + + ! Finalize dusfc and dvsfc diagnostics + dusfc(i) = (-1./g*rcs) * dusfc(i) + dvsfc(i) = (-1./g*rcs) * dvsfc(i) + + if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then + do k = kts,km + dtaux2d_ls(i,k) = taud_ls(i,k) * xn(i) + dtauy2d_ls(i,k) = taud_ls(i,k) * yn(i) + dtaux2d_bl(i,k) = taud_bl(i,k) * xn(i) + dtauy2d_bl(i,k) = taud_bl(i,k) * yn(i) + dusfc_ls(i) = dusfc_ls(i) + dtaux2d_ls(i,k) * del(i,k) + dvsfc_ls(i) = dvsfc_ls(i) + dtauy2d_ls(i,k) * del(i,k) + dusfc_bl(i) = dusfc_bl(i) + dtaux2d_bl(i,k) * del(i,k) + dvsfc_bl(i) = dvsfc_bl(i) + dtauy2d_bl(i,k) * del(i,k) + enddo + endif + + endif ! if ( ls_taper(i) .GT. 1.E-02 ) + + enddo ! do i=its,im + +ENDIF ! (do_gsl_drag_ls_bl).and.(gwd_opt_ls.EQ.1 .OR. gwd_opt_bl.EQ.1) + +if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then + ! Finalize dusfc and dvsfc diagnostics + do i = its,im + dusfc_ls(i) = (-1./g*rcs) * dusfc_ls(i) + dvsfc_ls(i) = (-1./g*rcs) * dvsfc_ls(i) + dusfc_bl(i) = (-1./g*rcs) * dusfc_bl(i) + dvsfc_bl(i) = (-1./g*rcs) * dvsfc_bl(i) + dusfc_ss(i) = (-1./g*rcs) * dusfc_ss(i) + dvsfc_ss(i) = (-1./g*rcs) * dvsfc_ss(i) + dusfc_fd(i) = (-1./g*rcs) * dusfc_fd(i) + dvsfc_fd(i) = (-1./g*rcs) * dvsfc_fd(i) + enddo +endif +! + return + end subroutine drag_suite_run +!------------------------------------------------------------------- +! + subroutine drag_suite_finalize() + end subroutine drag_suite_finalize + + end module drag_suite From 96502941f925197d6278caa3419dcdfe0bd96553 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Thu, 20 Jan 2022 04:34:35 +0000 Subject: [PATCH 095/212] Update dimensions of SPP fields --- physics/drag_suite.F90 | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 31fb4fd50..0f843387f 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -606,14 +606,16 @@ subroutine drag_suite_run( & do i = its,im var_stoch(i) = var(i) + var(i)*0.75*spp_wts_gwd(i,1) varss_stoch(i) = varss(i) + varss(i)*0.75*spp_wts_gwd(i,1) - varmax_ss_stoch = varmax_ss + varmax_ss*0.75*spp_wts_gwd(i,1) - varmax_fd_stoch = varmax_fd + varmax_fd*0.75*spp_wts_gwd(i,1) + varmax_ss_stoch(i) = varmax_ss + varmax_ss*0.75*spp_wts_gwd(i,1) + varmax_fd_stoch(i) = varmax_fd + varmax_fd*0.75*spp_wts_gwd(i,1) enddo else - var_stoch = var - varss_stoch = varss - varmax_ss_stoch = varmax_ss - varmax_fd_stoch = varmax_fd + do i=its,im + var_stoch(i) = var(i) + varss_stoch(i) = varss(i) + varmax_ss_stoch(i) = varmax_ss + varmax_fd_stoch(i) = varmax_fd + enddo endif !--- calculate length of grid for flow-blocking drag @@ -1001,8 +1003,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) + & - MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch)) + var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & + MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_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) @@ -1016,8 +1018,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) + & - MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch)) + var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & + MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_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) From 63c5f96260aca15fc3757f358437a317b48243e0 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Thu, 20 Jan 2022 04:35:55 +0000 Subject: [PATCH 096/212] Update dimensions for two SPP fields --- physics/drag_suite.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 0f843387f..7fea98b13 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -610,7 +610,7 @@ subroutine drag_suite_run( & varmax_fd_stoch(i) = varmax_fd + varmax_fd*0.75*spp_wts_gwd(i,1) enddo else - do i=its,im + do i = its,im var_stoch(i) = var(i) varss_stoch(i) = varss(i) varmax_ss_stoch(i) = varmax_ss @@ -1083,8 +1083,8 @@ 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) + & - MAX(0.,beta_fd*(varss_stoch(i)-varmax_fd_stoch)) + 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.) a1=0.00026615161*var_temp**2 ! a1=0.00026615161*MIN(varss(i),varmax)**2 From 307e67f4cb8f0d5dd951b6084941efcff45d570d Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 20 Jan 2022 11:40:19 -0700 Subject: [PATCH 097/212] remove some accidental reversions in radiation_clouds.f --- physics/radiation_clouds.f | 68 +++++++++++++++++--------------------- 1 file changed, 31 insertions(+), 37 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 888087e56..c3e0b1293 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3206,7 +3206,8 @@ subroutine progcld6 & enddo enddo - ! What portion of water and ice contents is associated with the partly cloudy boxes + ! What portion of water and ice contents is associated with the + ! partly cloudy boxes do i = 1, IX do k = 1, NLAY-1 if (cldtot(i,k).ge.climit .and. cldtot(i,k).lt.ovcst) then @@ -3364,7 +3365,7 @@ subroutine progcld_thompson & ! 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) ! -! gridkm : grid length in km ! +! gridkm (IX) : grid length in km ! ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! ! uni_cld : logical - true for cloud fraction from shoc ! @@ -3423,8 +3424,8 @@ subroutine progcld_thompson & 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, gridkm + real(kind=kind_phys), dimension(:), intent(in) :: latdeg, gridkm + real(kind=kind_phys), intent(in) :: julian integer, intent(in) :: yearlen ! --- outputs @@ -3498,14 +3499,14 @@ subroutine progcld_thompson & enddo !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . -!> - Since using Thompson MP, assume 20 percent of snow is actually in +!> - Since using Thompson MP, assume 1 percent of snow is actually in !! ice sizes. do k = 1, NLAY-1 do i = 1, IX cwp(i,k) = max(0.0, clw(i,k,ntcw) * dz(i,k)*1.E6) crp(i,k) = 0.0 - snow_mass_factor = 0.85 + snow_mass_factor = 0.99 cip(i,k) = max(0.0, (clw(i,k,ntiw) & & + (1.0-snow_mass_factor)*clw(i,k,ntsw))*dz(i,k)*1.E6) if (re_snow(i,k) .gt. snow_max_radius)then @@ -3571,7 +3572,7 @@ subroutine progcld_thompson & endif call cal_cldfra3(cldfra1d, qv1d, qc1d, qi1d, qs1d, dz1d, & - & p1d, t1d, xland, gridkm, & + & p1d, t1d, xland, gridkm(i), & & .false., max_relh, 1, nlay, .false.) do k = 1, NLAY @@ -4611,16 +4612,16 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & DO k = kts,kte delz = MAX(100., dz(k)) - RH_00L = 0.74+MIN(0.25,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) - RH_00O = 0.82+MIN(0.17,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00L = 0.77+MIN(0.22,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00O = 0.85+MIN(0.14,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) RHUM = rh(k) - if (qc(k).ge.1.E-5 .or. qi(k).ge.1.E-5 & - & .or. (qs(k).gt.1.E-5 .and. t(k).lt.273.)) then + if (qc(k).ge.1.E-6 .or. qi(k).ge.1.E-7 & + & .or. (qs(k).gt.1.E-6 .and. t(k).lt.273.)) then CLDFRA(K) = 1.0 elseif (((qc(k)+qi(k)).gt.1.E-10) .and. & - & ((qc(k)+qi(k)).lt.1.E-5)) then - CLDFRA(K) = MIN(0.99, 0.20*(10.0 + log10(qc(k)+qi(k)))) + & ((qc(k)+qi(k)).lt.1.E-6)) then + CLDFRA(K) = MIN(0.99, 0.1*(11.0 + log10(qc(k)+qi(k)))) else IF ((XLAND-1.5).GT.0.) THEN !--- Ocean @@ -4629,7 +4630,7 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & RH_00 = RH_00L ENDIF - tc = t(k) - 273.15 + tc = MAX(-80.0, t(k) - 273.15) if (tc .lt. -12.0) RH_00 = RH_00L if (tc .gt. 20.0) then @@ -4641,12 +4642,12 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & if (max_relh.gt.1.12 .or. (.NOT.(modify_qvapor)) ) then !..For HRRR model, the following look OK. RHUM = MIN(rh(k), 1.45) - RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+112.) + RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+85.) CLDFRA(K) = MAX(0.,1.0-SQRT((1.46-RHUM)/(1.46-RH_00))) else !..but for the GFS model, RH is way lower. RHUM = MIN(rh(k), 1.05) - RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+112.) + RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+85.) CLDFRA(K) = MAX(0.,1.0-SQRT((1.06-RHUM)/(1.06-RH_00))) endif endif @@ -4664,15 +4665,6 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & call adjust_cloudFinal(cldfra, qc, qi, rhoa, dz, kts,kte) - if (debug_flag .and. ndebug.lt.25) then - do k = kts,kte - write(6,'(a,i3,f9.2,f7.1,f7.2,f6.1,f6.3,f12.7,f12.7,f12.7)') & - & ' DEBUG-GT: ', k, p(k)*0.01, dz(k), t(k)-273.15, & - & rh(k)*100., cldfra(k), qc(k)*1.E3, qi(k)*1.E3, qs(k)*1.E3 - enddo - ndebug = ndebug + 1 - endif - !..Intended for cold start model runs, we use modify_qvapor to ensure that cloudy !.. areas are actually saturated such that the inserted clouds do not evaporate a !.. timestep later. @@ -4814,9 +4806,9 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, entrmnt,& k = k - 1 ENDDO - k_cldb = k_m12C + 5 + k_cldb = k_m12C + 3 in_cloud = .false. - k = k_m12C + 4 + k = k_m12C + 2 DO WHILE (.not. in_cloud .AND. k.gt.kbot) k_cldt = 0 if (cfr1d(k).ge.0.01) then @@ -4865,12 +4857,13 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) do k = k1, k2 tdz = tdz + dz(k) enddo - max_iwc = ABS(qvs(k2)-qvs(k1)) +! max_iwc = ABS(qvs(k2)-qvs(k1)) + max_iwc = MAX(0.0, qvs(k1)-qvs(k2)) do k = k1, k2 - max_iwc = MAX(1.E-5, max_iwc - (qi(k)+qs(k))) + max_iwc = MAX(1.E-6, max_iwc - (qi(k)+qs(k))) enddo - max_iwc = MIN(2.E-3, max_iwc) + max_iwc = MIN(1.E-4, max_iwc) this_dz = 0.0 do k = k1, k2 @@ -4880,7 +4873,7 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) this_dz = this_dz + dz(k) endif this_iwc = max_iwc*this_dz/tdz - iwc = MAX(5.E-6, this_iwc*(1.-entr)) + iwc = MAX(1.E-6, this_iwc*(1.-entr)) if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.203.16) then qi(k) = qi(k) + cfr(k)*cfr(k)*iwc endif @@ -4905,13 +4898,14 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) do k = k1, k2 tdz = tdz + dz(k) enddo - max_lwc = ABS(qvs(k2)-qvs(k1)) +! max_lwc = ABS(qvs(k2)-qvs(k1)) + max_lwc = MAX(0.0, qvs(k1)-qvs(k2)) ! print*, ' max_lwc = ', max_lwc, ' over DZ=',tdz do k = k1, k2 - max_lwc = MAX(1.E-5, max_lwc - qc(k)) + max_lwc = MAX(1.E-6, max_lwc - qc(k)) enddo - max_lwc = MIN(2.E-3, max_lwc) + max_lwc = MIN(1.E-4, max_lwc) this_dz = 0.0 do k = k1, k2 @@ -4921,8 +4915,8 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) this_dz = this_dz + dz(k) endif this_lwc = max_lwc*this_dz/tdz - lwc = MAX(5.E-6, this_lwc*(1.-entr)) - if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.253.16) then + lwc = MAX(1.E-6, this_lwc*(1.-entr)) + if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.258.16) then qc(k) = qc(k) + cfr(k)*cfr(k)*lwc endif enddo @@ -4974,6 +4968,6 @@ SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte) END SUBROUTINE adjust_cloudFinal !........................................! - end module module_radiation_clouds ! + end module module_radiation_clouds !! @} !========================================! From 68f97b10aba252ba1dd03bc2a39566831698e686 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 24 Jan 2022 18:01:19 +0000 Subject: [PATCH 098/212] 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 099/212] 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 100/212] 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 101/212] 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 102/212] 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 103/212] 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 104/212] 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 105/212] 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 106/212] 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 6dcc5e0119e3d2351a8f8abc0ae53448bd79a1db Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 2 Feb 2022 18:55:56 +0000 Subject: [PATCH 107/212] updated gwdphys.f --- physics/gwdps.f | 111 +++++++++++++++++++++++++----------------------- 1 file changed, 59 insertions(+), 52 deletions(-) diff --git a/physics/gwdps.f b/physics/gwdps.f index 285bdf67c..12b2fefa0 100644 --- a/physics/gwdps.f +++ b/physics/gwdps.f @@ -323,7 +323,7 @@ subroutine gwdps_run( & real(kind=kind_phys) wk(IM) real(kind=kind_phys) bnv2lm(IM,KM),PE(IM),EK(IM),ZBK(IM),UP(IM) real(kind=kind_phys) DB(IM,KM),ANG(IM,KM),UDS(IM,KM) - real(kind=kind_phys) ZLEN, DBTMP, Rtrm, PHIANG, CDmb, DBIM, ZR + real(kind=kind_phys) ZLEN, Rtrm, PHIANG, CDmb, DBIM, ZR, cdmbo4 real(kind=kind_phys) ENG0, ENG1 ! ! Some constants @@ -382,13 +382,13 @@ subroutine gwdps_run( & real(kind=kind_phys) BNV2(IM,KM), TAUP(IM,KM+1), ri_n(IM,KM) & &, TAUD(IM,KM), RO(IM,KM), VTK(IM,KM) & &, VTJ(IM,KM), SCOR(IM), VELCO(IM,KM-1) & - &, bnv2bar(im) + &, bnv2bar(im), cdsigohp(im) ! ! real(kind=kind_phys) VELKO(KM-1) integer kref(IM), kint(im), iwk(im), ipt(im) ! for lm mtn blocking integer iwklm(im) -! integer kreflm(IM), iwklm(im) +! integer kreflm(IM), iwklm(im) integer idxzb(im), ktrial, klevm1 ! real(kind=kind_phys) gor, gocp, fv, gr2, bnv, fr & @@ -397,7 +397,7 @@ subroutine gwdps_run( & &, rdelks, efact, coefm, gfobnv, onebg & &, scork, rscor, hd, fro, rim, sira & &, dtaux, dtauy, pkp1log, pklog & - &, cosang, sinang, cos2a, sin2a + &, cosang, sinang, cos2a, sin2a, oneocpdt ! integer kmm1, kmm2, lcap, lcapp1, kbps, kbpsp1,kbpsm1 & &, kmps, idir, nwd, i, j, k, klcap, kp1, kmpbl, npt, npr, kmll @@ -413,11 +413,12 @@ subroutine gwdps_run( & ! cdmb = 192.0/float(IMX) cdmb = 4.0 * 192.0/float(IMX) if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) + cdmbo4 = 0.25 * cdmb ! npr = 0 DO I = 1, IM - DUSFC(I) = 0. - DVSFC(I) = 0. + DUSFC(I) = 0. + DVSFC(I) = 0. ENDDO ! DO K = 1, KM @@ -428,12 +429,13 @@ subroutine gwdps_run( & ENDDO ENDDO ! - RDI = 1.0 / RD - onebg = 1.0 / g - GOR = G/RD - GR2 = G*GOR - GOCP = G/CP - FV = RV/RD - 1 + RDI = 1.0 / RD + onebg = 1.0 / g + GOR = G/RD + GR2 = G*GOR + GOCP = G/CP + FV = RV/RD - 1 + oneocpdt = 1.0 / (cp*deltim) ! ! NCNT = 0 KMM1 = KM - 1 @@ -441,17 +443,17 @@ subroutine gwdps_run( & LCAP = KM LCAPP1 = LCAP + 1 ! + RDXZB(:) = 0 ! IF ( NMTVR == 14) then ! ---- for lm and gwd calculation points - RDXZB(:) = 0 ipt = 0 npt = 0 DO I = 1,IM IF (elvmax(i) > HMINMT .and. hprime(i) > hpmin) then - npt = npt + 1 - ipt(npt) = i - if (ipr == i) npr = npt + npt = npt + 1 + ipt(npt) = i +! if (lprnt .and. ipr == i) npr = npt ENDIF ENDDO IF (npt == 0) RETURN ! No gwd/mb calculation done! @@ -488,7 +490,8 @@ subroutine gwdps_run( & ! DO I = 1, npt j = ipt(i) - ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit) + ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit) + cdsigohp(i) = cdmbo4 * sigma(j) / hprime(j) ENDDO ! DO K = 1,KMLL @@ -626,8 +629,8 @@ subroutine gwdps_run( & ! --- Wind projected on the line perpendicular to mtn range, U(Zb(K)). ! --- kenetic energy is at the layer Zb ! --- THETA ranges from -+90deg |_ to the mtn "largest topo variations" - UP(I) = UDS(I,K) * cos(ANG(I,K)) - EK(I) = 0.5 * UP(I) * UP(I) + UP(I) = UDS(I,K) * cos(ANG(I,K)) + EK(I) = 0.5 * UP(I) * UP(I) ! --- Dividing Stream lime is found when PE =exceeds EK. IF (PE(I) >= EK(I)) THEN @@ -732,9 +735,8 @@ subroutine gwdps_run( & !! where \f$C_{d}\f$ is a specified constant, \f$\sigma\f$ is the !! orographic slope. - DBTMP = 0.25 * CDmb * ZR * sigma(J) * - & MAX(cosANG, gamma(J)*sinANG) * ZLEN / hprime(J) - DB(I,K) = DBTMP * UDS(I,K) + DB(i,k) = CDsigohp(i) * ZR * RO(i,k) * ZLEN + & * MAX(cosANG, gamma(J)*sinANG) * uds(i,k) ! ! if(lprnt .and. i .eq. npr) then ! print *,' in gwdps_lmi.f 10 npt=',npt,i,j,idxzb(i) @@ -770,7 +772,6 @@ subroutine gwdps_run( & ! do i=1,npt IDXZB(i) = 0 - RDXZB(i) = 0. enddo ENDIF ! @@ -884,9 +885,9 @@ subroutine gwdps_run( & ! ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! Mean RO below kref if (k < kref(i)-1) then - RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS(I) + RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS(I) else - RDELKS = (PRSL(J,K)-PRSI(J,K+1)) * DELKS(I) + RDELKS = (PRSL(J,K)-PRSI(J,K+1)) * DELKS(I) endif BNV2bar(I) = BNV2bar(I) + BNV2(I,K) * RDELKS ENDIF @@ -1126,9 +1127,9 @@ subroutine gwdps_run( & !!\f] !! see eq.(4.6) in Kim and Arakawa (1995) \cite kim_and_arakawa_1995. - TEM2 = SQRT(ri_n(I,K)) - TEM = 1. + TEM2 * FRO - RIM = ri_n(I,K) * (1.-FRO) / (TEM * TEM) + TEM2 = SQRT(ri_n(I,K)) + TEM = 1. + TEM2 * FRO + RIM = ri_n(I,K) * (1.-FRO) / (TEM * TEM) ! ! CHECK STABILITY TO EMPLOY THE 'SATURATION HYPOTHESIS' ! OF LINDZEN (1981) EXCEPT AT TROPOSPHERIC DOWNSTREAM REGIONS @@ -1168,7 +1169,7 @@ subroutine gwdps_run( & ! taup(i,km+1) = taup(i,km) ! ENDDO ! - IF(LCAP .LE. KM) THEN + IF(LCAP <= KM) THEN DO KLCAP = LCAPP1, KM+1 DO I = 1,npt SIRA = PRSI(ipt(I),KLCAP) / PRSI(ipt(I),LCAP) @@ -1209,7 +1210,7 @@ subroutine gwdps_run( & ENDDO ENDDO ! -! if(lprnt .and. npr .gt. 0) then +! if(lprnt .and. npr > 0) then ! print *,' before A=',A(npr,:) ! print *,' before B=',B(npr,:) ! endif @@ -1218,6 +1219,7 @@ subroutine gwdps_run( & !! - Below the dividing streamline height (k < idxzb), mountain !! blocking(\f$D_{b}\f$) is applied. !! - Otherwise (k>= idxzb), orographic GWD (\f$\tau\f$) is applied. + DO K = 1,KM DO I = 1,npt J = ipt(i) @@ -1225,30 +1227,35 @@ subroutine gwdps_run( & DTAUX = TAUD(I,K) * XN(I) DTAUY = TAUD(I,K) * YN(I) ENG0 = 0.5*(U1(j,K)*U1(j,K)+V1(J,K)*V1(J,K)) -! --- lm mb (*j*) changes overwrite GWD - if ( K < IDXZB(I) .AND. IDXZB(I) /= 0 ) then - DBIM = DB(I,K) / (1.+DB(I,K)*DELTIM) - A(J,K) = - DBIM * V1(J,K) + A(J,K) - B(J,K) = - DBIM * U1(J,K) + B(J,K) - ENG1 = ENG0*(1.0-DBIM*DELTIM)*(1.0-DBIM*DELTIM) -! if ( ABS(DBIM * U1(J,K)) .gt. .01 ) + + if (K < IDXZB(I)) then ! --- lm mb (*j*) changes overwrite GWD + ! --------------------------------------- + DBIM = DB(I,K) / (1.+DB(I,K)*DELTIM) + A(J,K) = - DBIM * V1(J,K) + A(J,K) + B(J,K) = - DBIM * U1(J,K) + B(J,K) + ENG1 = ENG0*(1.0-DBIM*DELTIM)*(1.0-DBIM*DELTIM) + +! if ( ABS(DBIM * U1(J,K)) > .01 ) ! & print *,' in gwdps_lmi.f KDT=',KDT,I,K,DB(I,K), ! & dbim,idxzb(I),U1(J,K),V1(J,K),me - DUSFC(J) = DUSFC(J) - DBIM * U1(J,K) * DEL(J,K) - DVSFC(J) = DVSFC(J) - DBIM * V1(J,K) * DEL(J,K) - else -! - A(J,K) = DTAUY + A(J,K) - B(J,K) = DTAUX + B(J,K) - ENG1 = 0.5*( - & (U1(J,K)+DTAUX*DELTIM)*(U1(J,K)+DTAUX*DELTIM) - & + (V1(J,K)+DTAUY*DELTIM)*(V1(J,K)+DTAUY*DELTIM)) - DUSFC(J) = DUSFC(J) + DTAUX * DEL(J,K) - DVSFC(J) = DVSFC(J) + DTAUY * DEL(J,K) + + tem1 = DBIM * DEL(J,K) + DUSFC(J) = DUSFC(J) - tem1 * U1(J,K) + DVSFC(J) = DVSFC(J) - tem1 * V1(J,K) + else ! orographic GWD applied + ! ---------------------- + A(J,K) = DTAUY + A(J,K) + B(J,K) = DTAUX + B(J,K) + tem1 = U1(J,K) + DTAUX*DELTIM + tem2 = V1(J,K) + DTAUY*DELTIM + ENG1 = 0.5 * (tem1*tem1+tem2*tem2) + DUSFC(J) = DUSFC(J) + DTAUX * DEL(J,K) + DVSFC(J) = DVSFC(J) + DTAUY * DEL(J,K) endif - C(J,K) = C(J,K) + max(ENG0-ENG1,0.)/CP/DELTIM + C(J,K) = C(J,K) + max(ENG0-ENG1,0.) * oneocpdt ENDDO ENDDO + ! if (lprnt) then ! print *,' in gwdps_lm.f after A=',A(ipr,:) ! print *,' in gwdps_lm.f after B=',B(ipr,:) @@ -1256,8 +1263,8 @@ subroutine gwdps_run( & ! endif DO I = 1,npt - J = ipt(i) -! TEM = (-1.E3/G) + J = ipt(i) +! TEM = (-1.E3/G) DUSFC(J) = - onebg * DUSFC(J) DVSFC(J) = - onebg * DVSFC(J) ENDDO @@ -1310,4 +1317,4 @@ end subroutine gwdps_run subroutine gwdps_finalize() end subroutine gwdps_finalize - end module gwdps \ No newline at end of file + end module gwdps From e87f7a5378720f77c224cd6798a069bf5d392c18 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 2 Feb 2022 14:36:55 -0700 Subject: [PATCH 108/212] bugfixes to pass ccpp_prebuild.py after merge with main --- physics/GFS_phys_time_vary.fv3.meta | 1 - physics/GFS_phys_time_vary.scm.meta | 1 - physics/sfc_drv_ruc.F90 | 4 ++-- physics/sfc_drv_ruc.meta | 2 -- 4 files changed, 2 insertions(+), 6 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 4f85a0b0f..b4ede6f5a 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -874,7 +874,6 @@ type = real kind = kind_phys intent = in - optional = F [lsm_cold_start] standard_name = do_lsm_cold_start long_name = flag to signify LSM is cold-started diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta index eafeb6dd8..21ebfb8e0 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/GFS_phys_time_vary.scm.meta @@ -874,7 +874,6 @@ type = real kind = kind_phys intent = in - optional = F [lsm_cold_start] standard_name = do_lsm_cold_start long_name = flag to signify LSM is cold-started diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 64c75012a..4c42f17fe 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -1,4 +1,4 @@ -+!>\file sfc_drv_ruc.F90 +!>\file sfc_drv_ruc.F90 !! This file contains the RUC land surface scheme driver. module lsm_ruc @@ -210,7 +210,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & sh2o, smfrkeep, tslb, smois, & ! out wetness, errmsg, errflg) - if (.not.flag_restart) then + if (lsm_cold_start) then do i = 1, im ! i - horizontal loop do k = 1, min(kice,lsoil_ruc) ! - at initial time set sea ice T (tsice) diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index df3fe5a9b..b9709c4d3 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -42,7 +42,6 @@ dimensions = () type = integer intent = in - optional = F [lsm_cold_start] standard_name = do_lsm_cold_start long_name = flag to signify LSM is cold-started @@ -1567,7 +1566,6 @@ dimensions = () type = logical intent = in - optional = F [lsm_cold_start] standard_name = do_lsm_cold_start long_name = flag to signify LSM is cold-started From 8e4357b6153b644c83a30ada39f224b4ae6cb809 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 8 Feb 2022 19:44:22 -0700 Subject: [PATCH 109/212] GPU-enabled version of Grell-Freitas convection --- physics/cu_gf_deep.F90 | 617 +++++++++++++++++++++++++++++----- physics/cu_gf_driver.F90 | 133 +++++++- physics/cu_gf_driver_post.F90 | 3 + physics/cu_gf_driver_pre.F90 | 11 + physics/cu_gf_sh.F90 | 118 ++++++- 5 files changed, 780 insertions(+), 102 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index e26afef3e..f59a985cd 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -47,6 +47,27 @@ module cu_gf_deep contains + integer function my_maxloc1d(A,N,dir) +!$acc routine vector + implicit none + real(kind_phys), intent(in) :: A(:) + integer, intent(in) :: N,dir + + real(kind_phys) :: imaxval + integer :: i + + imaxval = MAXVAL(A) + my_maxloc1d = 1 +!$acc loop + do i = 1, N + if ( A(i) == imaxval ) then + my_maxloc1d = i + return + endif + end do + return + end function my_maxloc1d + !>\ingroup cu_gf_deep_group !> \section general_gf_deep GF Deep Convection General Algorithm !> @{ @@ -126,13 +147,16 @@ subroutine cu_gf_deep_run( & ,intent (in ) :: rand_clos real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: rand_mom,rand_vmas +!$acc declare copyin(rand_clos,rand_mom,rand_vmas) integer, intent(in) :: do_capsuppress - real(kind=kind_phys), intent(in), optional, dimension(:) :: cap_suppress_j + real(kind=kind_phys), intent(in), dimension(:) :: cap_suppress_j +!$acc declare create(cap_suppress_j) ! ! ! real(kind=kind_phys), dimension (its:ite,1:maxens3) :: xf_ens,pr_ens +!$acc declare create(xf_ens,pr_ens) ! outtem = output temp tendency (per s) ! outq = output q tendency (per s) ! outqc = output qc tendency (per s) @@ -146,15 +170,19 @@ subroutine cu_gf_deep_run( & real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & pre,xmb_out +!$acc declare copy(cnvwt,outu,outv,outt,outq,outqc,cupclw,frh_out,pre,xmb_out) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & hfx,qfx,xmbm_in,xmbs_in +!$acc declare copyin(hfx,qfx,xmbm_in,xmbs_in) integer, dimension (its:ite) & ,intent (inout ) :: & kbcon,ktop +!$acc declare copy(kbcon,ktop) integer, dimension (its:ite) & ,intent (in ) :: & kpbl,tropics +!$acc declare copyin(kpbl,tropics) ! ! basic environmental input includes moisture convergence (mconv) ! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off @@ -163,18 +191,23 @@ subroutine cu_gf_deep_run( & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & dhdt,rho,t,po,us,vs,tn +!$acc declare copyin(dhdt,rho,t,po,us,vs,tn) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & omeg +!$acc declare copy(omeg) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & q,qo,zuo,zdo,zdm +!$acc declare copy(q,qo,zuo,zdo,zdm) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & dx,z1,psur,xland +!$acc declare copyin(dx,z1,psur,xland) real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & mconv,ccn +!$acc declare copy(mconv,ccn) real(kind=kind_phys) & @@ -191,6 +224,7 @@ subroutine cu_gf_deep_run( & edtc real(kind=kind_phys), dimension (its:ite,kts:kte,1) :: & dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens +!$acc declare create(xaa0_ens,edtc,dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens) ! ! ! @@ -275,6 +309,17 @@ subroutine cu_gf_deep_run( & cd,cdd,dellah,dellaq,dellat,dellaqc, & u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv +!$acc declare create( & +!$acc entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo, & +!$acc xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup, & +!$acc p_cup,gamma_cup,t_cup, qeso_cup,qo_cup,heo_cup,heso_cup, & +!$acc zo_cup,po_cup,gammao_cup,tn_cup, & +!$acc xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & +!$acc xt_cup, dby,hc,zu,clw_all, & +!$acc dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco, & +!$acc dbyt,xdby,xhc,xzu, & +!$acc cd,cdd,dellah,dellaq,dellat,dellaqc, & +!$acc u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv) ! aa0 cloud work function for downdraft ! edt = epsilon @@ -294,9 +339,18 @@ subroutine cu_gf_deep_run( & integer, dimension (its:ite) :: & kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & ktopdby,kbconx,ierr2,ierr3,kbmax +!$acc declare create(edt,edto,edtm,aa1,aa0,xaa0,hkb, & +!$acc hkbo,xhkb, & +!$acc xmb,pwavo,ccnloss, & +!$acc pwevo,bu,bud,cap_max, & +!$acc cap_max_increment,closure_n,psum,psumh,sig,sigd, & +!$acc axx,edtmax,edtmin,entr_rate, & +!$acc kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & +!$acc ktopdby,kbconx,ierr2,ierr3,kbmax) integer, dimension (its:ite), intent(inout) :: ierr integer, dimension (its:ite), intent(in) :: csum +!$acc declare copy(ierr) copyin(csum) integer :: & iloop,nens3,ki,kk,i,k real(kind=kind_phys) :: & @@ -307,9 +361,11 @@ subroutine cu_gf_deep_run( & detup,subdown,entdoj,entupk,detupk,totmas real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec +!$acc declare create(lambau,flux_tun,zws,ztexec,zqexec) integer :: jprnt,jmini,start_k22 logical :: keep_going,flg(its:ite) +!$acc declare create(flg) character*50 :: ierrc(its:ite) character*4 :: cumulus @@ -318,9 +374,12 @@ subroutine cu_gf_deep_run( & ,up_massentro,up_massdetro,dd_massentro,dd_massdetro real(kind=kind_phys), dimension (its:ite,kts:kte) :: & up_massentru,up_massdetru,dd_massentru,dd_massdetru +!$acc declare create(up_massentr,up_massdetr,c1d,up_massentro,up_massdetro,dd_massentro,dd_massdetro, & +!$acc up_massentru,up_massdetru,dd_massentru,dd_massdetru) real(kind=kind_phys) c1_max,buo_flux,pgcon,pgc,blqe real(kind=kind_phys) :: xff_mid(its:ite,2) +!$acc declare create(xff_mid) integer :: iversion=1 real(kind=kind_phys) :: denom,h_entr,umean,t_star,dq integer, intent(in) :: dicycle @@ -329,32 +388,46 @@ subroutine cu_gf_deep_run( & ,qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl & ,gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl real(kind=kind_phys), dimension(its:ite) :: xf_dicycle +!$acc declare create(aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean, & +!$acc tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl, & +!$acc qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl, & +!$acc gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl,xf_dicycle) real(kind=kind_phys), intent(inout), dimension(its:ite,10) :: forcing +!$acc declare copy(forcing) integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers real(kind=kind_phys), dimension (its:ite) :: c0 ! HCB +!$acc declare create(pmin_lev,start_level,ktopkeep,dtempdz,k_inv_layers,c0) ! rainevap from sas real(kind=kind_phys) zuh2(40) real(kind=kind_phys), dimension (its:ite) :: rntot,delqev,delq2,qevap,rn,qcond +!$acc declare create(zuh2,rntot,delqev,delq2,qevap,rn,qcond) real(kind=kind_phys) :: rain,t1,q1,elocp,evef,el2orc,evfact,evfactl,g_rain,e_dn,c_up real(kind=kind_phys) :: pgeoh,dts,fp,fpi,pmin,x_add,beta,beta_u real(kind=kind_phys) :: cbeg,cmid,cend,const_a,const_b,const_c !---meltglac------------------------------------------------- real(kind=kind_phys), dimension (its:ite,kts:kte) :: p_liq_ice,melting_layer,melting +!$acc declare create(p_liq_ice,melting_layer,melting) + + integer :: itemp !---meltglac------------------------------------------------- +!$acc kernels melting_layer(:,:)=0. melting(:,:)=0. flux_tun(:)=fluxtune +!$acc end kernels ! if(imid.eq.1)flux_tun(:)=fluxtune+.5 cumulus='deep' if(imid.eq.1)cumulus='mid' pmin=150. if(imid.eq.1)pmin=75. +!$acc kernels ktopdby(:)=0 +!$acc end kernels c1_max=c1 elocp=xlv/cp el2orc=xlv*xlv/(r_v*cp) @@ -370,18 +443,21 @@ subroutine cu_gf_deep_run( & ! ! ecmwf pgcon=0. +!$acc kernels lambau(:)=2.0 if(imid.eq.1)lambau(:)=2.0 ! here random must be between -1 and 1 if(nranflag == 1)then lambau(:)=1.5+rand_mom(:) endif +!$acc end kernels ! sas ! lambau=0. ! pgcon=-.55 ! !---------------------------------------------------- ! HCB ! Set cloud water to rain water conversion rate (c0) +!$acc kernels c0(:)=0.004 do i=its,itf xland1(i)=int(xland(i)+.0001) ! 1. @@ -393,8 +469,10 @@ subroutine cu_gf_deep_run( & c0(i)=0.002 endif enddo +!$acc end kernels !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!$acc kernels ztexec(:) = 0. zqexec(:) = 0. zws(:) = 0. @@ -419,10 +497,12 @@ subroutine cu_gf_deep_run( & zws(i) = 1.2*zws(i)**.3333 zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct enddo +!$acc end kernels ! cap_maxs=225. ! if(imid.eq.1)cap_maxs=150. cap_maxs=75. ! 150. ! if(imid.eq.1)cap_maxs=100. +!$acc kernels do i=its,itf edto(i)=0. closure_n(i)=16. @@ -441,14 +521,20 @@ subroutine cu_gf_deep_run( & if(ztexec(i).gt.0.)cap_max(i)=cap_max(i)+25. if(ztexec(i).lt.0.)cap_max(i)=cap_max(i)-25. endif +#ifndef _OPENACC ierrc(i)=" " +#endif ! cap_max_increment(i)=1. enddo +!$acc end kernels if(use_excess == 0 )then +!$acc kernels ztexec(:)=0 zqexec(:)=0 +!$acc end kernels endif if(do_capsuppress == 1) then +!$acc kernels do i=its,itf cap_max(i)=cap_maxs if (abs(cap_suppress_j(i) - 1.0 ) < 0.1 ) then @@ -457,12 +543,18 @@ subroutine cu_gf_deep_run( & cap_max(i)=10.0 endif enddo +!$acc end kernels endif ! !--- initial entrainment rate (these may be changed later on in the !--- program ! +!$acc kernels start_level(:)=kte +!$acc end kernels + +!$acc kernels +!$acc loop private(radius,frh) do i=its,ite c1d(i,:)= 0. !c1 ! 0. ! c1 ! max(.003,c1+float(csum(i))*.0001) entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6 @@ -479,6 +571,7 @@ subroutine cu_gf_deep_run( & sig(i)=(1.-frh)**2 frh_out(i) = frh enddo +!$acc end kernels sig_thresh = (1.-frh_thresh)**2 @@ -488,6 +581,7 @@ subroutine cu_gf_deep_run( & ! !--- initial detrainmentrates ! +!$acc kernels do k=kts,ktf do i=its,itf cnvwt(i,k)=0. @@ -504,14 +598,17 @@ subroutine cu_gf_deep_run( & dellaqc(i,k)=0. enddo enddo +!$acc end kernels ! !--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft ! base mass flux ! +!$acc kernels edtmax(:)=1. if(imid.eq.1)edtmax(:)=.15 edtmin(:)=.1 if(imid.eq.1)edtmin(:)=.05 +!$acc end kernels ! !--- minimum depth (m), clouds must have ! @@ -521,6 +618,7 @@ subroutine cu_gf_deep_run( & !--- maximum depth (mb) of capping !--- inversion (larger cap = no convection) ! +!$acc kernels do i=its,itf ! if(imid.eq.0)then ! edtmax(i)=max(0.5,.8-float(csum(i))*.015) !.3) @@ -533,8 +631,9 @@ subroutine cu_gf_deep_run( & kstabm(i)=ktf-1 ierr2(i)=0 ierr3(i)=0 - x_add=0. enddo +!$acc end kernels + x_add=0. ! do i=its,itf ! cap_max(i)=cap_maxs ! cap_max3(i)=25. @@ -559,13 +658,14 @@ subroutine cu_gf_deep_run( & ! !--- environmental conditions, first heights ! +!$acc kernels do i=its,itf do k=1,maxens3 xf_ens(i,k)=0. pr_ens(i,k)=0. enddo enddo - +!$acc end kernels ! !> - Call cup_env() to calculate moist static energy, heights, qes ! @@ -596,6 +696,7 @@ subroutine cu_gf_deep_run( & call get_partition_liq_ice(ierr,tn,po_cup,p_liq_ice,melting_layer,& itf,ktf,its,ite,kts,kte,cumulus) !---meltglac------------------------------------------------- +!$acc kernels do i=its,itf if(ierr(i).eq.0)then if(kpbl(i).gt.5 .and. imid.eq.1)cap_max(i)=po_cup(i,kpbl(i)) @@ -629,29 +730,36 @@ subroutine cu_gf_deep_run( & ! endif enddo +!$acc end kernels + ! ! ! !> - Determine level with highest moist static energy content (\p k22) ! start_k22=2 +!$acc parallel loop do 36 i=its,itf if(ierr(i).eq.0)then k22(i)=maxloc(heo_cup(i,start_k22:kbmax(i)+2),1)+start_k22-1 if(k22(i).ge.kbmax(i))then ierr(i)=2 +#ifndef _OPENACC ierrc(i)="could not find k22" +#endif ktop(i)=0 k22(i)=0 kbcon(i)=0 endif endif 36 continue +!$acc end parallel + ! !> - call get_cloud_bc() and cup_kbcon() to determine the !! level of convective cloud base (\p kbcon) ! - +!$acc parallel loop private(x_add) do i=its,itf if(ierr(i).eq.0)then x_add = xlv*zqexec(i)+cp*ztexec(i) @@ -659,6 +767,8 @@ subroutine cu_gf_deep_run( & call get_cloud_bc(kte,heo_cup (i,1:kte),hkbo (i),k22(i),x_add) endif ! ierr enddo +!$acc end parallel + jprnt=0 iloop=1 if(imid.eq.1)iloop=5 @@ -674,6 +784,7 @@ subroutine cu_gf_deep_run( & call cup_minimi(heso_cup,kbcon,kstabm,kstabi,ierr, & itf,ktf, & its,ite, kts,kte) +!$acc parallel loop private(frh,x_add) do i=its,itf if(ierr(i) == 0)then frh = min(qo_cup(i,kbcon(i))/qeso_cup(i,kbcon(i)),1.) @@ -686,6 +797,7 @@ subroutine cu_gf_deep_run( & ! ! if(imid.eq.0 .and. xland1(i).eq.0)x_add=150. x_add=0. +!$acc loop seq do k=kbcon(i)+1,ktf if(po(i,kbcon(i))-po(i,k) > pmin+x_add)then pmin_lev(i)=k @@ -700,6 +812,8 @@ subroutine cu_gf_deep_run( & call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) endif enddo +!$acc end parallel + ! !--- get inversion layers for mid level cloud tops ! @@ -707,6 +821,7 @@ subroutine cu_gf_deep_run( & call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers, & kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) endif +!$acc kernels do i=its,itf if(kstabi(i).lt.kbcon(i))then kbcon(i)=1 @@ -729,6 +844,7 @@ subroutine cu_gf_deep_run( & ktop(i)=min(kstabi(i),k_inv_layers(i,2)) ktopdby(i)=ktop(i) else +!$acc loop seq do k=kbcon(i)+1,ktf if((po_cup(i,k22(i))-po_cup(i,k)).gt.500.)then ktop(i)=k @@ -741,6 +857,8 @@ subroutine cu_gf_deep_run( & endif enddo +!$acc end kernels + ! !> - Call rates_up_pdf() to get normalized mass flux, entrainment and detrainmentrates for updraft ! @@ -757,20 +875,24 @@ subroutine cu_gf_deep_run( & ! ! ! +!$acc kernels do i=its,itf if(ierr(i).eq.0)then if(k22(i).gt.1)then +!$acc loop independent do k=1,k22(i) -1 zuo(i,k)=0. zu (i,k)=0. xzu(i,k)=0. enddo endif +!$acc loop independent do k=k22(i),ktop(i) xzu(i,k)= zuo(i,k) zu (i,k)= zuo(i,k) enddo +!$acc loop independent do k=ktop(i)+1,kte zuo(i,k)=0. zu (i,k)=0. @@ -778,6 +900,7 @@ subroutine cu_gf_deep_run( & enddo endif enddo +!$acc end kernels ! !> - Call get_lateral_massflux() to calculate mass entrainment and detrainment ! @@ -785,12 +908,12 @@ subroutine cu_gf_deep_run( & call get_lateral_massflux(itf,ktf, its,ite, kts,kte & ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & ,up_massentro, up_massdetro ,up_massentr, up_massdetr & - ,'mid',kbcon,k22,up_massentru,up_massdetru,lambau) + ,3,kbcon,k22,up_massentru,up_massdetru,lambau) else call get_lateral_massflux(itf,ktf, its,ite, kts,kte & ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & ,up_massentro, up_massdetro ,up_massentr, up_massdetr & - ,'deep',kbcon,k22,up_massentru,up_massdetru,lambau) + ,1,kbcon,k22,up_massentru,up_massdetru,lambau) endif @@ -798,6 +921,7 @@ subroutine cu_gf_deep_run( & ! note: ktop here already includes overshooting, ktopdby is without ! overshooting ! +!$acc kernels do k=kts,ktf do i=its,itf uc (i,k)=0. @@ -823,17 +947,19 @@ subroutine cu_gf_deep_run( & hco(i,k)=hkbo(i) endif enddo - +!$acc end kernels ! !---meltglac------------------------------------------------- ! !--- 1st guess for moist static energy and dbyo (not including ice phase) ! +!$acc parallel loop private(denom,kk,ki) do i=its,itf ktopkeep(i)=0 dbyt(i,:)=0. if(ierr(i) /= 0) cycle ktopkeep(i)=ktop(i) +!$acc loop seq do k=start_level(i) +1,ktop(i) !mass cons option denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) @@ -847,8 +973,9 @@ subroutine cu_gf_deep_run( & dbyo(i,k)=hco(i,k)-heso_cup(i,k) enddo ! for now no overshooting (only very little) - kk=maxloc(dbyt(i,:),1) - ki=maxloc(zuo(i,:),1) + !kk=maxloc(dbyt(i,:),1) + !ki=maxloc(zuo(i,:),1) +!$acc loop seq do k=ktop(i)-1,kbcon(i),-1 if(dbyo(i,k).gt.0.)then ktopkeep(i)=k+1 @@ -858,12 +985,16 @@ subroutine cu_gf_deep_run( & !ktop(i)=ktopkeep(i) !if(ierr(i).eq.0)ktop(i)=ktopkeep(i) enddo +!$acc end parallel + +!$acc kernels do 37 i=its,itf kzdown(i)=0 if(ierr(i).eq.0)then zktop=(zo_cup(i,ktop(i))-z1(i))*.6 if(imid.eq.1)zktop=(zo_cup(i,ktop(i))-z1(i))*.4 zktop=min(zktop+z1(i),zcutdown+z1(i)) +!$acc loop seq do k=kts,ktf if(zo_cup(i,k).gt.zktop)then kzdown(i)=k @@ -873,12 +1004,15 @@ subroutine cu_gf_deep_run( & enddo endif 37 continue +!$acc end kernels + ! !--- downdraft originating level - jmin ! call cup_minimi(heso_cup,k22,kzdown,jmin,ierr, & itf,ktf, & its,ite, kts,kte) +!$acc kernels do 100 i=its,itf if(ierr(i).eq.0)then ! @@ -899,6 +1033,7 @@ subroutine cu_gf_deep_run( & hcdo(i,ki)=heso_cup(i,ki) dz=zo_cup(i,ki+1)-zo_cup(i,ki) dh=0. +!$acc loop seq do k=ki-1,1,-1 hcdo(i,k)=heso_cup(i,jmini) dz=zo_cup(i,k+1)-zo_cup(i,k) @@ -909,7 +1044,9 @@ subroutine cu_gf_deep_run( & keep_going = .true. else ierr(i) = 9 +#ifndef _OPENACC ierrc(i) = "could not find jmini9" +#endif exit endif endif @@ -918,7 +1055,9 @@ subroutine cu_gf_deep_run( & jmin(i) = jmini if ( jmini .le. 5 ) then ierr(i)=4 +#ifndef _OPENACC ierrc(i) = "could not find jmini4" +#endif endif endif 100 continue @@ -945,12 +1084,13 @@ subroutine cu_gf_deep_run( & ! endif ! enddo ! if(imid.eq.1)c1d(i,:)=0.003 - +!$acc loop independent do k=ktop(i)+1,ktf hco(i,k)=heso_cup(i,k) dbyo(i,k)=0. enddo enddo +!$acc end kernels ! !> - Call cup_up_moisture() to calculate moisture properties of updraft ! @@ -975,13 +1115,14 @@ subroutine cu_gf_deep_run( & ! ,itf,ktf,its,ite, kts,kte, cumulus ) !---meltglac------------------------------------------------- - +!$acc kernels do i=its,itf ktopkeep(i)=0 dbyt(i,:)=0. if(ierr(i) /= 0) cycle ktopkeep(i)=ktop(i) +!$acc loop seq do k=start_level(i) +1,ktop(i) !mass cons option denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) @@ -1027,6 +1168,7 @@ subroutine cu_gf_deep_run( & ! ierr(i)=423 ! endif ! +!$acc loop seq do k=ktop(i)-1,kbcon(i),-1 if(dbyo(i,k).gt.0.)then ktopkeep(i)=k+1 @@ -1036,7 +1178,10 @@ subroutine cu_gf_deep_run( & !ktop(i)=ktopkeep(i) !if(ierr(i).eq.0)ktop(i)=ktopkeep(i) enddo +!$acc end kernels + 41 continue +!$acc kernels do i=its,itf if(ierr(i) /= 0) cycle do k=ktop(i)+1,ktf @@ -1061,10 +1206,14 @@ subroutine cu_gf_deep_run( & if(ierr(i)/=0)cycle if(ktop(i).lt.kbcon(i)+2)then ierr(i)=5 +#ifndef _OPENACC ierrc(i)='ktop too small deep' +#endif ktop(i)=0 endif enddo +!$acc end kernels + !! do 37 i=its,itf ! kzdown(i)=0 ! if(ierr(i).eq.0)then @@ -1133,20 +1282,25 @@ subroutine cu_gf_deep_run( & ! - must have at least depth_min m between cloud convective base ! and cloud top. ! +!$acc kernels do i=its,itf if(ierr(i).eq.0)then if ( jmin(i) - 1 .lt. kdet(i) ) kdet(i) = jmin(i)-1 if(-zo_cup(i,kbcon(i))+zo_cup(i,ktop(i)).lt.depth_min)then ierr(i)=6 +#ifndef _OPENACC ierrc(i)="cloud depth very shallow" +#endif endif endif enddo +!$acc end kernels ! !--- normalized downdraft mass flux profile,also work on bottom detrainment !--- in this routine ! +!$acc kernels do k=kts,ktf do i=its,itf zdo(i,k)=0. @@ -1162,6 +1316,9 @@ subroutine cu_gf_deep_run( & mentrd_rate_2d(i,k)=entr_rate(i) enddo enddo +!$acc end kernels + +!$acc parallel loop private(beta,itemp,dzo,h_entr) do i=its,itf if(ierr(i)/=0)cycle beta=max(.025,.055-float(csum(i))*.0015) !.02 @@ -1174,7 +1331,8 @@ subroutine cu_gf_deep_run( & cdd(i,jmin(i))=0. dd_massdetro(i,:)=0. dd_massentro(i,:)=0. - call get_zu_zd_pdf_fim(0,po_cup(i,:),rand_vmas(i),0.0_kind_phys,ipr,xland1(i),zuh2,"down",ierr(i),kdet(i),jmin(i)+1,zdo(i,:),kts,kte,ktf,beta,kpbl(i),csum(i),pmin_lev(i)) + call get_zu_zd_pdf_fim(0,po_cup(i,:),rand_vmas(i),0.0_kind_phys,ipr,xland1(i),zuh2,4, & + ierr(i),kdet(i),jmin(i)+1,zdo(i,:),kts,kte,ktf,beta,kpbl(i),csum(i),pmin_lev(i)) if(zdo(i,jmin(i)) .lt.1.e-8)then zdo(i,jmin(i))=0. jmin(i)=jmin(i)-1 @@ -1185,8 +1343,9 @@ subroutine cu_gf_deep_run( & cycle endif endif - - do ki=jmin(i) ,maxloc(zdo(i,:),1),-1 + + itemp = maxloc(zdo(i,:),1) + do ki=jmin(i) , itemp,-1 !=> from jmin to maximum value zd -> change entrainment dzo=zo_cup(i,ki+1)-zo_cup(i,ki) dd_massdetro(i,ki)=cdd(i,ki)*dzo*zdo(i,ki+1) @@ -1199,7 +1358,7 @@ subroutine cu_gf_deep_run( & if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) enddo mentrd_rate_2d(i,1)=0. - do ki=maxloc(zdo(i,:),1)-1,1,-1 + do ki=itemp-1,1,-1 !=> from maximum value zd to surface -> change detrainment dzo=zo_cup(i,ki+1)-zo_cup(i,ki) dd_massentro(i,ki)=mentrd_rate_2d(i,ki)*dzo*zdo(i,ki+1) @@ -1244,6 +1403,7 @@ subroutine cu_gf_deep_run( & dbydo(i,jmin(i))=hcdo(i,jmin(i))-heso_cup(i,jmin(i)) bud(i)=dbydo(i,jmin(i))*(zo_cup(i,jmin(i)+1)-zo_cup(i,jmin(i))) ucd(i,jmin(i)+1)=.5*(uc(i,jmin(i)+1)+u_cup(i,jmin(i)+1)) +!$acc loop seq do ki=jmin(i) ,1,-1 dzo=zo_cup(i,ki+1)-zo_cup(i,ki) h_entr=.5*(heo(i,ki)+.5*(hco(i,ki)+hco(i,ki+1))) @@ -1268,9 +1428,13 @@ subroutine cu_gf_deep_run( & if(bud(i).gt.0)then ierr(i)=7 +#ifndef _OPENACC ierrc(i)='downdraft is not negatively buoyant ' +#endif endif enddo +!$acc end parallel + ! !> - Call cup_dd_moisture() to calculate moisture properties of downdraft ! @@ -1299,6 +1463,7 @@ subroutine cu_gf_deep_run( & ! its,ite, kts,kte) ! endif !---meltglac------------------------------------------------- +!$acc kernels do i=its,itf if(ierr(i)/=0)cycle do k=kts+1,ktop(i) @@ -1307,6 +1472,7 @@ subroutine cu_gf_deep_run( & cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp enddo enddo +!$acc end kernels ! !> - Call cup_up_aa0() to calculate workfunctions for updrafts ! @@ -1318,20 +1484,28 @@ subroutine cu_gf_deep_run( & kbcon,ktop,ierr, & itf,ktf, & its,ite, kts,kte) + +!$acc kernels do i=its,itf if(ierr(i)/=0)cycle if(aa1(i).eq.0.)then ierr(i)=17 +#ifndef _OPENACC ierrc(i)="cloud work function zero" +#endif endif enddo +!$acc end kernels + ! !--- diurnal cycle closure ! !--- aa1 from boundary layer (bl) processes only +!$acc kernels aa1_bl (:) = 0.0 xf_dicycle (:) = 0.0 tau_ecmwf (:) = 0. +!$acc end kernels !- way to calculate the fraction of cape consumed by shallow convection iversion=1 ! ecmwf !iversion=0 ! orig @@ -1341,6 +1515,7 @@ subroutine cu_gf_deep_run( & ! wmean is of no meaning over land.... ! still working on replacing it over water ! +!$acc kernels do i=its,itf if(ierr(i).eq.0)then !- mean vertical velocity @@ -1353,8 +1528,11 @@ subroutine cu_gf_deep_run( & endif enddo tau_bl(:) = 0. +!$acc end kernels + ! if(dicycle == 1) then +!$acc kernels do i=its,itf if(ierr(i).eq.0)then @@ -1369,6 +1547,7 @@ subroutine cu_gf_deep_run( & endif enddo +!$acc end kernels if(iversion == 1) then !-- version ecmwf @@ -1380,7 +1559,7 @@ subroutine cu_gf_deep_run( & zo_cup,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & kbcon,ktop,ierr, & itf,ktf,its,ite, kts,kte) - +!$acc kernels do i=its,itf if(ierr(i).eq.0)then @@ -1395,11 +1574,13 @@ subroutine cu_gf_deep_run( & !endif endif enddo +!$acc end kernels else !- version for real cloud-work function +!$acc kernels !-get the profiles modified only by bl tendencies do i=its,itf tn_bl(i,:)=0.;qo_bl(i,:)=0. @@ -1412,6 +1593,7 @@ subroutine cu_gf_deep_run( & qo_bl(i,kbcon(i)+1:ktf) = q(i,kbcon(i)+1:ktf) endif enddo +!$acc end kernels !--- calculate moist static energy, heights, qes, ... only by bl tendencies call cup_env(zo,qeso_bl,heo_bl,heso_bl,tn_bl,qo_bl,po,z1, & psur,ierr,tcrit,-1, & @@ -1421,6 +1603,7 @@ subroutine cu_gf_deep_run( & heo_cup_bl,heso_cup_bl,zo_cup,po_cup,gammao_cup_bl,tn_cup_bl,psur, & ierr,z1, & itf,ktf,its,ite, kts,kte) +!$acc kernels do i=its,itf if(ierr(i).eq.0)then hkbo_bl(i)=heo_cup_bl(i,k22(i)) @@ -1458,12 +1641,12 @@ subroutine cu_gf_deep_run( & enddo endif enddo - +!$acc end kernels !--- calculate workfunctions for updrafts call cup_up_aa0(aa1_bl,zo,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & kbcon,ktop,ierr, & itf,ktf,its,ite, kts,kte) - +!$acc kernels do i=its,itf if(ierr(i).eq.0)then @@ -1476,14 +1659,18 @@ subroutine cu_gf_deep_run( & ! !- multiply aa1_bl the "normalized time-scale" - tau_bl/ model_timestep aa1_bl(i) = aa1_bl(i)* tau_bl(i)/ dtime !endif - print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) +#ifndef _OPENACC + print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) +#endif endif enddo +!$acc end kernels endif endif ! version of implementation - +!$acc kernels axx(:)=aa1(:) +!$acc end kernels ! !> - Call cup_dd_edt() to determine downdraft strength in terms of windshear @@ -1501,6 +1688,7 @@ subroutine cu_gf_deep_run( & call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & ,pwo,edto,pwdo,melting & ,itf,ktf,its,ite, kts,kte, cumulus ) +!$acc kernels do k=kts,ktf do i=its,itf dellat_ens (i,k,1)=0. @@ -1524,6 +1712,7 @@ subroutine cu_gf_deep_run( & dellaqc(i,k)=0. enddo enddo +!$acc end kernels ! !---------------------------------------------- cloud level ktop ! @@ -1563,7 +1752,7 @@ subroutine cu_gf_deep_run( & !---------------------------------------------- cloud level 2 ! !- - - - - - - - - - - - - - - - - - - - - - - - model level 1 - +!$acc kernels do i=its,itf if(ierr(i)/=0)cycle dp=100.*(po_cup(i,1)-po_cup(i,2)) @@ -1603,8 +1792,10 @@ subroutine cu_gf_deep_run( & totmas=subin-subdown+detup-entup-entdo+ & detdo-entupk-entdoj+detupk+zuo(i,k+1)-zuo(i,k) if(abs(totmas).gt.1.e-6)then +#ifndef _OPENACC write(0,123)'totmas=',k22(i),kbcon(i),k,entup,detup,edto(i),zdo(i,k+1),dd_massdetro(i,k),dd_massentro(i,k) 123 format(a7,1x,3i3,2e12.4,1(1x,f5.2),3e12.4) +#endif endif dp=100.*(po_cup(i,k)-po_cup(i,k+1)) pgc=pgcon @@ -1706,11 +1897,14 @@ subroutine cu_gf_deep_run( & endif enddo +!$acc end kernels + 444 format(1x,i2,1x,7e12.4) !,1x,f7.2,2x,e13.5) ! !--- using dellas, calculate changed environmental profiles ! mbdt=.1 +!$acc kernels do i=its,itf xaa0_ens(i,1)=0. enddo @@ -1743,6 +1937,7 @@ subroutine cu_gf_deep_run( & xt(i,ktf)=tn(i,ktf) endif enddo +!$acc end kernels ! !--- calculate moist static energy, heights, qes ! @@ -1764,12 +1959,15 @@ subroutine cu_gf_deep_run( & ! !--- moist static energy inside cloud ! +!$acc kernels do k=kts,ktf do i=its,itf xhc(i,k)=0. xdby(i,k)=0. enddo enddo +!$acc end kernels +!$acc parallel loop private(x_add,k) do i=its,itf if(ierr(i).eq.0)then x_add = xlv*zqexec(i)+cp*ztexec(i) @@ -1781,10 +1979,13 @@ subroutine cu_gf_deep_run( & xhc(i,k)=xhkb(i) endif !ierr enddo +!$acc end parallel ! ! +!$acc kernels do i=its,itf if(ierr(i).eq.0)then +!$acc loop seq do k=start_level(i) +1,ktop(i) xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1) + & up_massentro(i,k-1)*xhe(i,k-1)) / & @@ -1800,13 +2001,14 @@ subroutine cu_gf_deep_run( & xdby(i,k)=xhc(i,k)-xhes_cup(i,k) enddo +!$acc loop independent do k=ktop(i)+1,ktf xhc (i,k)=xhes_cup(i,k) xdby(i,k)=0. enddo endif enddo - +!$acc end kernels ! !--- workfunctions for updraft ! @@ -1814,10 +2016,13 @@ subroutine cu_gf_deep_run( & kbcon,ktop,ierr, & itf,ktf, & its,ite, kts,kte) +!$acc parallel loop do i=its,itf if(ierr(i).eq.0)then xaa0_ens(i,1)=xaa0(i) +!$acc loop seq do k=kts,ktop(i) +!$acc loop independent do nens3=1,maxens3 if(nens3.eq.7)then !--- b=0 @@ -1839,7 +2044,9 @@ subroutine cu_gf_deep_run( & enddo if(pr_ens(i,7).lt.1.e-6)then ierr(i)=18 +#ifndef _OPENACC ierrc(i)="total normalized condensate too small" +#endif do nens3=1,maxens3 pr_ens(i,nens3)=0. enddo @@ -1851,6 +2058,7 @@ subroutine cu_gf_deep_run( & enddo endif enddo +!$acc end parallel 200 continue ! !--- large scale forcing @@ -1860,11 +2068,13 @@ subroutine cu_gf_deep_run( & ! ensemble is chosen ! ! +!$acc kernels do i=its,itf ierr2(i)=ierr(i) ierr3(i)=ierr(i) k22x(i)=k22(i) enddo +!$acc end kernels call cup_maximi(heo_cup,2,kbmax,k22x,ierr, & itf,ktf, & its,ite, kts,kte) @@ -1885,15 +2095,18 @@ subroutine cu_gf_deep_run( & ! !--- calculate cloud base mass flux ! - +!$acc kernels do i = its,itf mconv(i) = 0 if(ierr(i)/=0)cycle +!$acc loop independent do k=1,ktop(i) dq=(qo_cup(i,k+1)-qo_cup(i,k)) +!$acc atomic update mconv(i)=mconv(i)+omeg(i,k)*dq/g enddo enddo +!$acc end kernels call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt,dtime, & ierr,ierr2,ierr3,xf_ens,axx,forcing, & maxens3,mconv,rand_clos, & @@ -1903,6 +2116,7 @@ subroutine cu_gf_deep_run( & its,ite, kts,kte, & dicycle,tau_ecmwf,aa1_bl,xf_dicycle) ! +!$acc kernels do k=kts,ktf do i=its,itf if(ierr(i).eq.0)then @@ -1918,11 +2132,14 @@ subroutine cu_gf_deep_run( & endif enddo enddo +!$acc end kernels + 250 continue ! !--- feedback ! if(imid.eq.1 .and. ichoice .le.2)then +!$acc kernels do i=its,itf !-boundary layer qe xff_mid(i,1)=0. @@ -1941,6 +2158,7 @@ subroutine cu_gf_deep_run( & xff_mid(i,2)=min(0.1,.03*zws(i)) endif enddo +!$acc end kernels endif call cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat_ens,dellaq_ens, & dellaqc_ens,outt, & @@ -1959,6 +2177,7 @@ subroutine cu_gf_deep_run( & po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) k=1 +!$acc kernels do i=its,itf if(ierr(i).eq.0 .and.pre(i).gt.0.) then pre(i)=max(pre(i),0.) @@ -1980,9 +2199,11 @@ subroutine cu_gf_deep_run( & enddo endif enddo +!$acc end kernels ! rain evaporation as in sas ! if(irainevap.eq.1)then +!$acc kernels do i = its,itf rntot(i) = 0. delqev(i) = 0. @@ -1991,8 +2212,10 @@ subroutine cu_gf_deep_run( & rntot(i) = 0. rain=0. if(ierr(i).eq.0)then +!$acc loop independent do k = ktop(i), 1, -1 rain = pwo(i,k) + edto(i) * pwdo(i,k) +!$acc atomic rntot(i) = rntot(i) + rain * xmb(i)* .001 * dtime enddo endif @@ -2003,6 +2226,7 @@ subroutine cu_gf_deep_run( & if(ierr(i).eq.0)then evef = edt(i) * evfact * sig(i)**2 if(xland(i).gt.0.5 .and. xland(i).lt.1.5) evef = edt(i) * evfactl * sig(i)**2 +!$acc loop seq do k = ktop(i), 1, -1 rain = pwo(i,k) + edto(i) * pwdo(i,k) rn(i) = rn(i) + rain * xmb(i) * .001 * dtime @@ -2037,8 +2261,10 @@ subroutine cu_gf_deep_run( & ! pre(i)=1000.*rn(i)/dtime endif enddo +!$acc end kernels endif +!$acc kernels do i=its,itf if(ierr(i).eq.0) then if(aeroevap.gt.1)then @@ -2048,9 +2274,12 @@ subroutine cu_gf_deep_run( & endif endif enddo +!$acc end kernels + ! ! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) ! +!$acc kernels do i=its,itf if(ierr(i).eq.0) then dts=0. @@ -2070,7 +2299,7 @@ subroutine cu_gf_deep_run( & endif endif enddo - +!$acc end kernels ! !---------------------------done------------------------------ @@ -2083,7 +2312,7 @@ end subroutine cu_gf_deep_run subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) - +!$acc routine vector ! --- modify a 1-D array of tracer fluxes for the purpose of maintaining ! --- monotonicity (including positive-definiteness) in the tracer field ! --- during tracer transport. @@ -2188,9 +2417,10 @@ subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) / (1.0001*dtovdz(k))) clipout(k)=min(damp,(soln_lo(k)-trmin(k))/max(epsil,totlout(k)) & / (1.0001*dtovdz(k))) - +#ifndef _OPENACC if (NaN(clipin(k))) print *,'(fct1d) error: clipin is NaN, k=',k if (NaN(clipout(k))) print *,'(fct1d) error: clipout is NaN, k=',k +#endif if (clipin(k).lt.0.) then ! print 100,'(fct1d) error: clipin < 0 at k =',k, & @@ -2215,7 +2445,9 @@ subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) end if trflx_out(k)=flx_lo(k)+clipped(k) if (NaN(trflx_out(k))) then +#ifndef _OPENACC print *,'(fct1d) error: trflx_out is NaN, k=',k +#endif error=.true. end if end do @@ -2227,6 +2459,7 @@ subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) !dellac(k)=soln_hi(k) end do +#ifndef _OPENACC if (vrbos .or. error) then ! do k=2,ktop ! write(32,99)k, & @@ -2256,6 +2489,7 @@ subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) ! end do if (error) stop '(fct1d error)' end if +#endif return end subroutine fct1d3 @@ -2277,6 +2511,8 @@ subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & real(kind=kind_phys), dimension(its:ite,kts:kte),intent(in) :: po_cup,qo_cup,qes_cup real(kind=kind_phys), dimension(its:ite) ,intent(inout) :: pre real(kind=kind_phys), dimension(its:ite,kts:kte),intent(inout) :: outt,outq !,outbuoy +!$acc declare copyin(ierr,kbcon,psur,xland,pwavo,edto,pwevo,xmb,po_cup,qo_cup,qes_cup) +!$acc declare copy(pre,outt,outq) !real, dimension(its:ite) ,intent(out) :: tot_evap_bcb !real, dimension(its:ite,kts:kte),intent(out) :: evap_bcb,net_prec_bcb @@ -2286,7 +2522,9 @@ subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & real(kind=kind_phys) :: RH_cr , del_t,del_q,dp,q_deficit real(kind=kind_phys), dimension(its:ite,kts:kte) :: evap_bcb,net_prec_bcb real(kind=kind_phys), dimension(its:ite) :: tot_evap_bcb +!$acc declare create(evap_bcb,net_prec_bcb,tot_evap_bcb) +!$acc kernels do i=its,itf evap_bcb (i,:)= 0.0 net_prec_bcb(i,:)= 0.0 @@ -2303,6 +2541,7 @@ subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & !net_prec_bcb(i,k) = xmb(i)*(pwavo(i)+edto(i)*pwevo(i)) !-- pwevo<0. net_prec_bcb(i,k) = pre(i) +!$acc loop seq do k=kbcon(i)-1, kts, -1 q_deficit = max(0.,(RH_cr*qes_cup(i,k) -qo_cup(i,k))) @@ -2340,6 +2579,7 @@ subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & pre(i) = pre(i) - evap_bcb(i,k) enddo enddo +!$acc end kernels end subroutine rain_evap_below_cloudbase @@ -2384,6 +2624,8 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copyin(rho,us,vs,z,p,pw,pwav,pwev,psum2,psumh,edtmax,edtmin,ktop,kbcon) +!$acc declare copyout(edtc,edt) copy(ccn,ierr) ! ! local variables in this routine ! @@ -2392,6 +2634,7 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & real(kind=kind_phys) einc,pef,pefb,prezk,zkbc real(kind=kind_phys), dimension (its:ite) :: & vshear,sdp,vws +!$acc declare create(vshear,sdp,vws) real(kind=kind_phys) :: prop_c,aeroadd,alpha3,beta3 prop_c=0. !10.386 alpha3 = 0.75 @@ -2405,6 +2648,7 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & ! ! */ calculate an average wind shear over the depth of the cloud ! +!$acc kernels do i=its,itf edt(i)=0. vws(i)=0. @@ -2480,6 +2724,7 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & if(edtc(i,1).lt.edtmin(i))edtc(i,1)=edtmin(i) endif enddo +!$acc end kernels end subroutine cup_dd_edt @@ -2517,21 +2762,25 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & ,intent (in ) :: & zd,hes_cup,hcd,qes_cup,q_cup,z_cup, & dd_massentr,dd_massdetr,gamma_cup,q,he +!$acc declare copyin(zd,hes_cup,hcd,qes_cup,q_cup,z_cup,dd_massentr,dd_massdetr,gamma_cup,q,he) integer & ,intent (in ) :: & iloop integer, dimension (its:ite) & ,intent (in ) :: & jmin +!$acc declare copyin(jmin) integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copy(ierr) real(kind=kind_phys), dimension (its:ite,kts:kte)& ,intent (out ) :: & qcd,qrcd,pwd real(kind=kind_phys), dimension (its:ite)& ,intent (out ) :: & pwev,bu +!$acc declare copyout(qcd,qrcd,pwd,pwev,bu) character*50 :: ierrc(its:ite) ! ! local variables in this routine @@ -2542,6 +2791,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & real(kind=kind_phys) :: & denom,dh,dz,dqeva +!$acc kernels do i=its,itf bu(i)=0. pwev(i)=0. @@ -2573,6 +2823,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & pwev(i)=pwev(i)+pwd(i,jmin(i)) ! *dz ! bu(i)=dz*dh +!$acc loop seq do ki=jmin(i)-1,1,-1 dz=z_cup(i,ki+1)-z_cup(i,ki) ! qcd(i,ki)=(qcd(i,ki+1)*(1.-.5*cdd(i,ki+1)*dz) & @@ -2617,15 +2868,20 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & if( (pwev(i).eq.0.) .and. (iloop.eq.1))then ! print *,'problem with buoy in cup_dd_moisture',i ierr(i)=7 +#ifndef _OPENACC ierrc(i)="problem with buoy in cup_dd_moisture" +#endif endif if(bu(i).ge.0.and.iloop.eq.1)then ! print *,'problem with buoy in cup_dd_moisture',i ierr(i)=7 +#ifndef _OPENACC ierrc(i)="problem2 with buoy in cup_dd_moisture" +#endif endif endif 100 continue +!$acc end kernels end subroutine cup_dd_moisture @@ -2664,18 +2920,23 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & p,t,q +!$acc declare copyin(p,t,q) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (out ) :: & he,hes,qes +!$acc declare copyout(he,hes,qes) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & z +!$acc declare copy(z) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & psur,z1 +!$acc declare copyin(psur,z1) integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copy(ierr) integer & ,intent (in ) :: & itest @@ -2687,6 +2948,7 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & i,k ! real(kind=kind_phys), dimension (1:2) :: ae,be,ht real(kind=kind_phys), dimension (its:ite,kts:kte) :: tv +!$acc declare create(tv) real(kind=kind_phys) :: tcrit,e,tvbar ! real(kind=kind_phys), external :: satvap ! real(kind=kind_phys) :: satvap @@ -2698,6 +2960,7 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & ! ae(1)=be(1)/273.+alog(610.71) ! be(2)=.622*ht(2)/.286 ! ae(2)=be(2)/273.+alog(610.71) +!$acc parallel loop collapse(2) private(e) do k=kts,ktf do i=its,itf if(ierr(i).eq.0)then @@ -2717,11 +2980,13 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & endif enddo enddo +!$acc end parallel ! !--- z's are calculated with changed h's and q's and t's !--- if itest=2 ! if(itest.eq.1 .or. itest.eq.0)then +!$acc kernels do i=its,itf if(ierr(i).eq.0)then z(i,1)=max(0.,z1(i))-(log(p(i,1))- & @@ -2730,7 +2995,9 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & enddo ! --- calculate heights +!$acc loop seq do k=kts+1,ktf +!$acc loop private(tvbar) do i=its,itf if(ierr(i).eq.0)then tvbar=.5*tv(i,k)+.5*tv(i,k-1) @@ -2739,7 +3006,9 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & endif enddo enddo +!$acc end kernels else if(itest.eq.2)then +!$acc kernels do k=kts,ktf do i=its,itf if(ierr(i).eq.0)then @@ -2748,12 +3017,14 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & endif enddo enddo +!$acc end kernels else if(itest.eq.-1)then endif ! !--- calculate moist static energy - he ! saturated moist static energy - hes ! +!$acc kernels do k=kts,ktf do i=its,itf if(ierr(i).eq.0)then @@ -2763,6 +3034,7 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & endif enddo enddo +!$acc end kernels end subroutine cup_env @@ -2802,15 +3074,19 @@ subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & qes,q,he,hes,z,p,t +!$acc declare copyin(qes,q,he,hes,z,p,t) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (out ) :: & qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup +!$acc declare copyout(qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & psur,z1 +!$acc declare copyin(psur,z1) integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copy(ierr) ! ! local variables in this routine ! @@ -2818,7 +3094,7 @@ subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & integer :: & i,k - +!$acc kernels do k=kts,ktf do i=its,itf qes_cup(i,k)=0. @@ -2864,7 +3140,7 @@ subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & *t_cup(i,1)))*qes_cup(i,1) endif enddo - +!$acc end kernels end subroutine cup_env_clev !>\ingroup cu_gf_deep_group @@ -2911,6 +3187,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 real(kind=kind_phys), dimension (its:ite,1:maxens3) & ,intent (inout ) :: & xf_ens +!$acc declare copy(pr_ens,xf_ens) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & zd,zu,p_cup,zdm @@ -2929,9 +3206,11 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & mconv,axx +!$acc declare copyin(zd,zu,p_cup,zdm,omeg,xaa0,rand_clos,aa1,edt,edtm,mconv,axx) real(kind=kind_phys), dimension (its:ite) & ,intent (inout) :: & aa0,closure_n +!$acc declare copy(aa0,closure_n) real(kind=kind_phys) & ,intent (in ) :: & mbdt @@ -2947,6 +3226,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 integer, dimension (its:ite) & ,intent (inout) :: & ierr,ierr2,ierr3 +!$acc declare copy(k22,kbcon,ktop,ierr,ierr2,ierr3) copyin(xland) integer & ,intent (in ) :: & ichoice @@ -2954,6 +3234,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 real(kind=kind_phys), intent(in) , dimension (its:ite) :: aa1_bl,tau_ecmwf real(kind=kind_phys), intent(inout), dimension (its:ite) :: xf_dicycle real(kind=kind_phys), intent(inout), dimension (its:ite,10) :: forcing +!$acc declare copyin(aa1_bl,tau_ecmwf) copy(xf_dicycle,forcing) !- local var real(kind=kind_phys) :: xff_dicycle ! @@ -2974,15 +3255,20 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 a1,a_ave,xff0,xomg!,aclim1,aclim2,aclim3,aclim4 real(kind=kind_phys), dimension (its:ite) :: ens_adj +!$acc declare create(kloc,ens_adj) ! +!$acc kernels ens_adj(:)=1. +!$acc end kernels xff_dicycle = 0. !--- large scale forcing ! +!$acc kernels +!$acc loop private(xff_ens3,xk) do 100 i=its,itf kloc(i)=1 if(ierr(i).eq.0)then @@ -3218,13 +3504,15 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 enddo endif ! ierror 100 continue + !$acc end kernels !- !- diurnal cycle mass flux !- if(dicycle == 1 )then - +!$acc kernels +!$acc loop private(xk) do i=its,itf xf_dicycle(i) = 0. if(ierr(i) /= 0)cycle @@ -3238,9 +3526,11 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 xf_dicycle(i)= xf_ens(i,10)-xf_dicycle(i) enddo +!$acc end kernels else +!$acc kernels xf_dicycle(:) = 0. - +!$acc end kernels endif !--------- @@ -3273,24 +3563,31 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & he_cup,hes_cup,p_cup +!$acc declare copyin(he_cup,hes_cup,p_cup) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & entr_rate,ztexec,zqexec,cap_inc,cap_max +!$acc declare copyin(entr_rate,ztexec,zqexec,cap_inc,cap_max) real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & hkb !,cap_max +!$acc declare copy(hkb) integer, dimension (its:ite) & ,intent (in ) :: & kbmax +!$acc declare copyin(kbmax) integer, dimension (its:ite) & ,intent (inout) :: & kbcon,k22,ierr +!$acc declare copy(kbcon,k22,ierr) integer & ,intent (in ) :: & iloop_in character*50 :: ierrc(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: z_cup,heo +!$acc declare copyin(z_cup,heo) integer, dimension (its:ite) :: iloop,start_level +!$acc declare create(iloop,start_level) ! ! local variables in this routine ! @@ -3300,10 +3597,16 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & real(kind=kind_phys) :: & x_add,pbcdif,plus,hetest,dz real(kind=kind_phys), dimension (its:ite,kts:kte) ::hcot +!$acc declare create(hcot) + ! !--- determine the level of convective cloud base - kbcon ! +!$acc kernels iloop(:)=iloop_in +!$acc end kernels + +!$acc parallel loop do 27 i=its,itf kbcon(i)=1 ! @@ -3317,6 +3620,7 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & ! if(iloop_in.eq.5)start_level(i)=kbcon(i) !== including entrainment for hetest hcot(i,1:start_level(i)) = hkb(i) +!$acc loop seq do k=start_level(i)+1,kbmax(i)+3 dz=z_cup(i,k)-z_cup(i,k-1) hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1) & @@ -3331,7 +3635,9 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & if(kbcon(i).gt.kbmax(i)+2)then if(iloop(i).ne.4)then ierr(i)=3 +#ifndef _OPENACC ierrc(i)="could not find reasonable kbcon in cup_kbcon" +#endif endif go to 27 endif @@ -3364,6 +3670,7 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & start_level(i)=k22(i) ! if(iloop_in.eq.5)start_level(i)=kbcon(i) hcot(i,1:start_level(i)) = hkb(i) +!$acc loop seq do k=start_level(i)+1,kbmax(i)+3 dz=z_cup(i,k)-z_cup(i,k-1) @@ -3377,13 +3684,16 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & if(kbcon(i).gt.kbmax(i)+2)then if(iloop(i).ne.4)then ierr(i)=3 +#ifndef _OPENACC ierrc(i)="could not find reasonable kbcon in cup_kbcon" +#endif endif go to 27 endif go to 32 endif 27 continue + !$acc end parallel end subroutine cup_kbcon @@ -3410,27 +3720,33 @@ subroutine cup_maximi(array,ks,ke,maxx,ierr, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & array +!$acc declare copyin(array) integer, dimension (its:ite) & ,intent (in ) :: & ierr,ke +!$acc declare copyin(ierr,ke) integer & ,intent (in ) :: & ks integer, dimension (its:ite) & ,intent (out ) :: & maxx +!$acc declare copyout(maxx) real(kind=kind_phys), dimension (its:ite) :: & x +!$acc declare create(x) real(kind=kind_phys) :: & xar integer :: & i,k +!$acc kernels do 200 i=its,itf maxx(i)=ks if(ierr(i).eq.0)then x(i)=array(i,ks) ! +!$acc loop seq do 100 k=ks,ke(i) xar=array(i,k) if(xar.ge.x(i)) then @@ -3440,6 +3756,7 @@ subroutine cup_maximi(array,ks,ke,maxx,ierr, & 100 continue endif 200 continue + !$acc end kernels end subroutine cup_maximi @@ -3466,23 +3783,29 @@ subroutine cup_minimi(array,ks,kend,kt,ierr, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & array +!$acc declare copyin(array) integer, dimension (its:ite) & ,intent (in ) :: & ierr,ks,kend +!$acc declare copyin(ierr,ks,kend) integer, dimension (its:ite) & ,intent (out ) :: & kt +!$acc declare copyout(kt) real(kind=kind_phys), dimension (its:ite) :: & x +!$acc declare create(x) integer :: & i,k,kstop +!$acc kernels do 200 i=its,itf kt(i)=ks(i) if(ierr(i).eq.0)then x(i)=array(i,ks(i)) kstop=max(ks(i)+1,kend(i)) ! +!$acc loop seq do 100 k=ks(i)+1,kstop if(array(i,k).lt.x(i)) then x(i)=array(i,k) @@ -3491,6 +3814,7 @@ subroutine cup_minimi(array,ks,kend,kt,ierr, & 100 continue endif 200 continue + !$acc end kernels end subroutine cup_minimi @@ -3525,6 +3849,7 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & integer, dimension (its:ite) & ,intent (in ) :: & kbcon,ktop +!$acc declare copyin(z,zu,gamma_cup,t_cup,dby,kbcon,ktop) ! ! input and output ! @@ -3533,9 +3858,11 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copy(ierr) real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & aa0 +!$acc declare copyout(aa0) ! ! local variables in this routine ! @@ -3545,6 +3872,7 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & real(kind=kind_phys) :: & dz,da ! +!$acc kernels do i=its,itf aa0(i)=0. enddo @@ -3562,6 +3890,7 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & if(aa0(i).lt.0.)aa0(i)=0. enddo enddo +!$acc end kernels end subroutine cup_up_aa0 @@ -3582,6 +3911,7 @@ subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & real(kind=kind_phys), dimension (its:ite ) , & intent(inout ) :: & pret +!$acc declare copy(outq,outt,outqc,outu,outv,q,pret) character *(*), intent (in) :: & name real(kind=kind_phys) & @@ -3601,11 +3931,14 @@ subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & names=1. endif scalef=86400. +!$acc kernels +!$acc loop private(qmemf,qmem,icheck) do i=its,itf if(ktop(i) <= 2)cycle icheck=0 qmemf=1. qmem=0. +!$acc loop reduction(min:qmemf) do k=kts,ktop(i) qmem=(outt(i,k))*86400. if(qmem.gt.thresh)then @@ -3633,6 +3966,7 @@ subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & enddo pret(i)=pret(i)*qmemf enddo +!$acc end kernels ! return ! ! check whether routine produces negative q's. this can happen, since @@ -3643,9 +3977,12 @@ subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & ! return ! write(14,*)'return' thresh=1.e-32 +!$acc kernels +!$acc loop private(qmemf,qmem,icheck) do i=its,itf if(ktop(i) <= 2)cycle qmemf=1. +!$acc loop reduction(min:qmemf) do k=kts,ktop(i) qmem=outq(i,k) if(abs(qmem).gt.0. .and. q(i,k).gt.1.e-6)then @@ -3670,7 +4007,7 @@ subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & enddo pret(i)=pret(i)*qmemf enddo - +!$acc end kernels end subroutine neg_check !>\ingroup cu_gf_deep_group @@ -3744,6 +4081,8 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ierr,ierr2,ierr3 integer, intent(in) :: dicycle real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle +!$acc declare copyin(zu,pwd,p_cup,sig,xmbm_in,xmbs_in,edt,xff_mid,dellat,dellaqc,dellaq,pw,ktop,xland1,xf_dicycle) +!$acc declare copy(xf_ens,pr_ens,outtem,outq,outqc,pre,xmb,closure_n,ierr,ierr2,ierr3) ! ! local variables in this routine ! @@ -3754,11 +4093,13 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & clos_wei,dtt,dp,dtq,dtqc,dtpw,dtpwd real(kind=kind_phys), dimension (its:ite) :: & pre2,xmb_ave,pwtot +!$acc declare create(pre2,xmb_ave,pwtot) ! character *(*), intent (in) :: & name ! +!$acc kernels do k=kts,kte do i=its,ite outtem (i,k)=0. @@ -3779,6 +4120,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & enddo endif enddo +!$acc end kernels ! !--- calculate ensemble average mass fluxes ! @@ -3788,10 +4130,12 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! !!!!! deep convection !!!!!!!!!! if(imid.eq.0)then +!$acc kernels do i=its,itf if(ierr(i).eq.0)then k=0 xmb_ave(i)=0. +!$acc loop seq do n=1,maxens3 k=k+1 xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) @@ -3825,8 +4169,10 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & endif enddo +!$acc end kernels !!!!! not so deep convection !!!!!!!!!! else ! imid == 1 +!$acc kernels do i=its,itf xmb_ave(i)=0. if(ierr(i).eq.0)then @@ -3836,6 +4182,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & xmb_ave(i)=sig(i)*xff_mid(i,ichoice) else if(ichoice.gt.2)then k=0 +!$acc loop seq do n=1,maxens3 k=k+1 xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) @@ -3856,8 +4203,10 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & endif ! dicycle=1,2 endif ! ierr >0 enddo ! i +!$acc end kernels endif ! imid=1 +!$acc kernels do i=its,itf if(ierr(i).eq.0)then dtpw=0. @@ -3870,8 +4219,10 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & PRE(I)=PRE(I)+XMB(I)*dtpw endif enddo +!$acc end kernels return +!$acc kernels do i=its,itf pwtot(i)=0. pre2(i)=0. @@ -3907,10 +4258,12 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & enddo pre(i)=-pre(i)+xmb(i)*pwtot(i) endif +#ifndef _OPENACC 124 format(1x,i3,4e13.4) 125 format(1x,2e13.4) +#endif enddo - +!$acc end kernels end subroutine cup_output_ens_3d !------------------------------------------------------- @@ -3957,6 +4310,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer, dimension (its:ite) & ,intent (in ) :: & kbcon,ktop,k22,xland1 +!$acc declare copyin(p_cup,rho,q,zu,gamma_cup,qe_cup,up_massentr,up_massdetr,dby,qes_cup,z_cup,zqexec,c0,kbcon,ktop,k22,xland1) real(kind=kind_phys), intent (in ) :: & ! HCB ccnclean ! @@ -3968,6 +4322,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copy(ierr) character *(*), intent (in) :: & name ! qc = cloud q (including liquid water) after entrainment @@ -3980,19 +4335,25 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (out ) :: & qc,qrc,pw,clw_all +!$acc declare copy(qc,qrc,pw,clw_all) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & c1d +!$acc declare copy(c1d) real(kind=kind_phys), dimension (its:ite,kts:kte) :: & qch,qrcb,pwh,clw_allh,c1d_b,t +!$acc declare create(qch,qrcb,pwh,clw_allh,c1d_b,t) real(kind=kind_phys), dimension (its:ite) :: & pwavh +!$acc declare create(pwavh) real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & pwav,psum,psumh +!$acc declare copyout(pwav,psum,psumh) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & ccn +!$acc declare copyin(ccn) ! ! local variables in this routine ! @@ -4000,6 +4361,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer :: & iprop,iall,i,k integer :: start_level(its:ite),kklev(its:ite) +!$acc declare create(start_level,kklev) real(kind=kind_phys) :: & prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & dz,berryc0,q1,berryc @@ -4007,19 +4369,30 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & denom, c0t, c0_iceconv real(kind=kind_phys), dimension (kts:kte) :: & prop_b +!$acc declare create(prop_b) ! + real(kind=kind_phys), parameter:: zero = 0 + logical :: is_mid, is_deep + + is_mid = (name == 'mid') + is_deep = (name == 'deep') + +!$acc kernels prop_b(kts:kte)=0 +!$acc end kernels iall=0 clwdet=0.1 !0.02 c0_iceconv=0.01 c1d_b=c1d bdsp=bdispm + ! !--- no precip for small clouds ! ! if(name.eq.'shallow')then ! c0=0.002 ! endif +!$acc kernels do i=its,itf pwav(i)=0. pwavh(i)=0. @@ -4039,10 +4412,13 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qrcb(i,k)=0. enddo enddo +!$acc end kernels + +!$acc parallel loop private(start_level,qaver,k) do i=its,itf if(ierr(i).eq.0)then start_level=k22(i) - call get_cloud_bc(kte,qe_cup (i,1:kte),qaver,k22(i)) + call get_cloud_bc(kte,qe_cup (i,1:kte),qaver,k22(i),zero) qaver = qaver k=start_level(i) qc (i,k)= qaver @@ -4056,7 +4432,10 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! endif enddo +!$acc end parallel + +!$acc kernels do 100 i=its,itf !c0=.004 HCB tuning if(ierr(i).eq.0)then @@ -4064,6 +4443,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! below lfc, but maybe above lcl ! ! if(name == "deep" )then +!$acc loop seq do k=k22(i)+1,kbcon(i) if(t(i,k) > 273.16) then c0t = c0(i) @@ -4090,13 +4470,14 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & !now do the rest ! kklev(i)=maxloc(zu(i,:),1) +!$acc loop seq do k=kbcon(i)+1,ktop(i) if(t(i,k) > 273.16) then c0t = c0(i) else c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) endif - if(name == "mid")c0t=0.004 + if(is_mid)c0t=0.004 denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) if(denom.lt.1.e-16)then @@ -4138,7 +4519,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) clw_allh(i,k)=max(0.,qch(i,k)-qrch) qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) - if(name == "deep" )then + if(is_deep)then clwdet=0.1 !0.02 ! 05/11/2021 if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 else @@ -4220,7 +4601,9 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & psum(i)=psum(i)+pw(i,k) ! HCB enddo ! k=kbcon,ktop ! do not include liquid/ice in qc +!$acc loop independent do k=k22(i)+1,ktop(i) +!$acc atomic qc(i,k)=qc(i,k)-qrc(i,k) enddo endif ! ierr @@ -4228,12 +4611,15 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & !--- integrated normalized ondensate ! 100 continue +!$acc end kernels prop_ave=0. iprop=0 +!$acc parallel loop reduction(+:prop_ave,iprop) do k=kts,kte prop_ave=prop_ave+prop_b(k) if(prop_b(k).gt.0)iprop=iprop+1 enddo +!$acc end parallel iprop=max(iprop,1) end subroutine cup_up_moisture @@ -4241,6 +4627,7 @@ end subroutine cup_up_moisture !-------------------------------------------------------------------- !>\ingroup cu_gf_deep_group real function satvap(temp2) +!$acc routine seq implicit none real(kind=kind_phys) :: temp2, temp, toot, toto, eilog, tsot, & & ewlog, ewlog2, ewlog3, ewlog4 @@ -4266,10 +4653,11 @@ real function satvap(temp2) !-------------------------------------------------------------------- !>\ingroup cu_gf_deep_group subroutine get_cloud_bc(mzp,array,x_aver,k22,add) +!$acc routine seq implicit none integer, intent(in) :: mzp,k22 - real(kind=kind_phys) , intent(in) :: array(mzp) - real(kind=kind_phys) , optional , intent(in) :: add + real(kind=kind_phys) , dimension(:), intent(in) :: array + real(kind=kind_phys) , intent(in) :: add real(kind=kind_phys) , intent(out) :: x_aver integer :: i,local_order_aver,order_aver @@ -4286,7 +4674,7 @@ subroutine get_cloud_bc(mzp,array,x_aver,k22,add) x_aver = x_aver + array(k22-i+1) enddo x_aver = x_aver/float(local_order_aver) - if(present(add)) x_aver = x_aver + add + x_aver = x_aver + add end subroutine get_cloud_bc !======================================================================================== @@ -4301,19 +4689,31 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo,rand_vmas integer, dimension (its:ite),intent (in) :: kstabi,k22,kpbl,csum,xland,pmin_lev integer, dimension (its:ite),intent (inout) :: kbcon,ierr,ktop,ktopdby +!$acc declare copy(entr_rate_2d,zuo,kbcon,ierr,ktop,ktopdby) & +!$acc copyin(p_cup, heo,heso_cup,z_cup,hkbo,rand_vmas,kstabi,k22,kpbl,csum,xland,pmin_lev) + !-local vars real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot +!$acc declare create(hcot) real(kind=kind_phys) :: entr_init,beta_u,dz,dbythresh,dzh2,zustart,zubeg,massent,massdetr real(kind=kind_phys) :: dby(kts:kte),dbm(kts:kte),zux(kts:kte) real(kind=kind_phys) zuh2(40),zh2(40) integer :: kklev,i,kk,kbegin,k,kfinalzu - integer, dimension (its:ite) :: start_level + integer, dimension (its:ite) :: start_level +!$acc declare create(start_level) + logical :: is_deep, is_mid, is_shallow ! zustart=.1 dbythresh= 0.8 !.0.95 ! 0.85, 0.6 if(name == 'shallow' .or. name == 'mid') dbythresh=1. - dby(:)=0. + !dby(:)=0. + + is_deep = (name .eq. 'deep') + is_mid = (name .eq. 'mid') + is_shallow = (name .eq. 'shallow') + +!$acc parallel loop private(beta_u,entr_init,dz,massent,massdetr,zubeg,kklev,kfinalzu,dby,dbm,zux,zuh2,zh2) do i=its,itf if(ierr(i) > 0 )cycle zux(:)=0. @@ -4326,6 +4726,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo zuo(i,start_level(i))=zustart zux(start_level(i))=zustart entr_init=entr_rate_2d(i,kts) +!$acc loop seq do k=start_level(i)+1,kbcon(i) dz=z_cup(i,k)-z_cup(i,k-1) massent=dz*entr_rate_2d(i,k-1)*zuo(i,k-1) @@ -4335,10 +4736,11 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo zux(k)=zuo(i,k) enddo zubeg=zustart !zuo(i,kbcon(i)) - if(name .eq. 'deep')then + if(is_deep)then ktop(i)=0 hcot(i,start_level(i))=hkbo(i) dz=z_cup(i,start_level(i))-z_cup(i,start_level(i)-1) +!$acc loop seq do k=start_level(i)+1,ktf-2 dz=z_cup(i,k)-z_cup(i,k-1) @@ -4350,6 +4752,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo enddo ktopdby(i)=maxloc(dby(:),1) kklev=maxloc(dbm(:),1) +!$acc loop seq do k=maxloc(dby(:),1)+1,ktf-2 if(dby(k).lt.dbythresh*maxval(dby))then kfinalzu=k - 1 @@ -4374,38 +4777,41 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo ! call get_zu_zd_pdf_fim(ipr,xland(i),zuh2,"up",ierr(i),start_level(i), & ! call get_zu_zd_pdf_fim(rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),kbcon(i), & ! kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kpbl(i),csum(i),pmin_lev(i)) - call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),k22(i), & + call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,1,ierr(i),k22(i), & kfinalzu+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! end deep - if ( name == 'mid' ) then + if ( is_mid ) then if(ktop(i) <= kbcon(i)+2)then ierr(i)=41 ktop(i)= 0 else kfinalzu=ktop(i) ktopdby(i)=ktop(i)+1 - call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"mid",ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,3, & + ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! mid - if ( name == 'shallow' ) then + if ( is_shallow ) then if(ktop(i) <= kbcon(i)+2)then ierr(i)=41 ktop(i)= 0 else kfinalzu=ktop(i) ktopdby(i)=ktop(i)+1 - call get_zu_zd_pdf_fim(kbcon(i),p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"sh2",ierr(i),k22(i), & + call get_zu_zd_pdf_fim(kbcon(i),p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,2,ierr(i),k22(i), & ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! shal enddo +!$acc end parallel loop end subroutine rates_up_pdf !------------------------------------------------------------------------- !>\ingroup cu_gf_deep_group subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,kb,kt,zu,kts,kte,ktf,max_mass,kpbli,csum,pmin_lev) +!$acc routine vector implicit none ! real(kind=kind_phys), parameter :: beta_deep=1.3,g_beta_deep=0.8974707 @@ -4421,7 +4827,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k real(kind=kind_phys), intent(in) :: p(kts:kte) real(kind=kind_phys) :: trash,beta_deep,zuh(kts:kte),zuh2(1:40) integer, intent(inout) :: ierr - character*(*), intent(in) ::draft + integer, intent(in) ::draft !- local var integer :: k1,kk,k,kb_adj,kpbli_adj,kmax @@ -4431,22 +4837,18 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! very simple lookup tables ! real(kind=kind_phys), dimension(30) :: alpha,g_alpha - data (alpha(k),k=4,27)/3.699999, & + data (alpha(k),k=1,30)/3.699999,3.699999,3.699999,3.699999,& 3.024999,2.559999,2.249999,2.028571,1.862500, & 1.733333,1.630000,1.545454,1.475000,1.415385, & 1.364286,1.320000,1.281250,1.247059,1.216667, & 1.189474,1.165000,1.142857,1.122727,1.104348, & - 1.087500,1.075000,1.075000/ - data (g_alpha(k),k=4,27)/4.170645, & + 1.087500,1.075000,1.075000,1.075000,1.075000,1.075000/ + data (g_alpha(k),k=1,30)/4.170645,4.170645,4.170645,4.170645, & 2.046925 , 1.387837, 1.133003, 1.012418,0.9494680, & 0.9153771,0.8972442,0.8885444,0.8856795,0.8865333, & 0.8897996,0.8946404,0.9005030,0.9070138,0.9139161, & 0.9210315,0.9282347,0.9354376,0.9425780,0.9496124, & - 0.9565111,0.9619183,0.9619183/ - alpha(1:3)=alpha(4) - g_alpha(1:3)=g_alpha(4) - alpha(28:30)=alpha(27) - g_alpha(28:30)=g_alpha(27) + 0.9565111,0.9619183,0.9619183,0.9619183,0.9619183,0.9619183/ !- kb cannot be at 1st level @@ -4454,7 +4856,15 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k zu(:)=0.0 zuh(:)=0.0 kb_adj=max(kb,2) - if(draft == "up") then + +! Dan: replaced draft string with integer +! up = 1 +! sh2 = 2 +! mid = 3 +! down = 4 +! downm = 5 + + if(draft == 1) then lev_start=min(.9,.1+csum*.013) kb_adj=max(kb,2) tunning=max(p(kklev+1),.5*(p(kpbli)+p(kt))) @@ -4495,7 +4905,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=maxloc(zu(:),1),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -4514,9 +4924,10 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! if(p(kt).gt.400.)write(32,122)k,p(k),zu(k),trash endif enddo +#ifndef _OPENACC 122 format(1x,i4,1x,f8.1,1x,f6.2,1x,f6.2) - - elseif(draft == "sh2") then +#endif + elseif(draft == 2) then k=kklev if(kpbli.gt.5)k=kpbli !new nov18 @@ -4553,7 +4964,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1))) if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=maxloc(zu(:),1),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -4566,7 +4977,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! write(32,122)k,p(k),zu(k) enddo - elseif(draft == "mid") then + elseif(draft == 3) then kb_adj=max(kb,2) tunning=.5*(p(kt)+p(kpbli)) !p(kt)+(p(kb_adj)-p(kt))*.9 !*.33 !new nov18 @@ -4602,7 +5013,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=maxloc(zu(:),1),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -4619,7 +5030,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! write(33,122)k,p(k),zu(k) enddo - elseif(draft == "down" .or. draft == "downm") then + elseif(draft == 4 .or. draft == 5) then tunning=p(kb) tunning =min(0.95, (tunning-p(1))/(p(kt)-p(1))) !=.6 @@ -4712,21 +5123,23 @@ subroutine cup_up_aa1bl(aa0,t,tn,q,qo,dtime, & real(kind=kind_phys) :: & dz,da ! +!$acc kernels do i=its,itf aa0(i)=0. enddo do i=its,itf +!$acc loop independent do k=kts,kbcon(i) if(ierr(i).ne.0 ) cycle ! if(k.gt.kbcon(i)) cycle dz = (z_cup (i,k+1)-z_cup (i,k))*g da = dz*(tn(i,k)*(1.+0.608*qo(i,k))-t(i,k)*(1.+0.608*q(i,k)))/dtime - +!$acc atomic aa0(i)=aa0(i)+da enddo enddo - +!$acc end kernels end subroutine cup_up_aa1bl !---------------------------------------------------------------------- @@ -4738,11 +5151,15 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay implicit none integer ,intent (in ) :: itf,ktf,its,ite,kts,kte integer, dimension (its:ite) ,intent (in ) :: ierr,kstart,kend +!$acc declare copyin(ierr,kstart,kend) integer, dimension (its:ite) :: kend_p3 +!$acc declare create(kend_p3) real(kind=kind_phys), dimension (its:ite,kts:kte), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup real(kind=kind_phys), dimension (its:ite,kts:kte), intent (out) :: dtempdz integer, dimension (its:ite,kts:kte), intent (out) :: k_inv_layers +!$acc declare copyin(p_cup,t_cup,z_cup,qo_cup,qeso_cup) +!$acc declare copyout(dtempdz,k_inv_layers) !-local vars real(kind=kind_phys) :: dp,l_mid,l_shal,first_deriv(kts:kte),sec_deriv(kts:kte) integer:: ken,kadd,kj,i,k,ilev,kk,ix,k800,k550,mid,shal @@ -4750,7 +5167,10 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay !-initialize k_inv_layers as undef l_mid=300. l_shal=100. +!$acc kernels k_inv_layers(:,:) = 1 +!$acc end kernels +!$acc parallel loop private(first_deriv,sec_deriv,ilev,ix,k,kadd,ken) do i = its,itf if(ierr(i) == 0)then sec_deriv(:)=0. @@ -4770,6 +5190,7 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay ix=1 k=ilev do while (ilev < kend_p3(i)) !(z_cup(i,ilev)<15000.) +!$acc loop seq do kk=k,kend_p3(i)+2 !k,ktf-2 if(sec_deriv(kk) < sec_deriv(kk+1) .and. & @@ -4786,6 +5207,7 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay !- 2nd criteria kadd=0 ken=maxloc(k_inv_layers(i,:),1) +!$acc loop seq do k=1,ken kk=k_inv_layers(i,k+kadd) if(kk.eq.1)exit @@ -4801,8 +5223,10 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay enddo endif enddo +!$acc end parallel 100 format(1x,16i3) !- find the locations of inversions around 800 and 550 hpa +!$acc parallel loop private(sec_deriv,shal,mid) do i = its,itf if(ierr(i) /= 0) cycle @@ -4827,13 +5251,14 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay k_inv_layers(i,mid )=k_inv_layers(i,k550) ! this is for mid/congestus convection k_inv_layers(i,mid+1:kte)=-1 enddo - +!$acc end parallel end subroutine get_inversion_layers !----------------------------------------------------------------------------------- !>\ingroup cu_gf_deep_group !> This function calcualtes function deriv3(xx, xi, yi, ni, m) +!$acc routine vector !============================================================================*/ ! evaluate first- or second-order derivatives ! using three-point lagrange interpolation @@ -4863,7 +5288,11 @@ function deriv3(xx, xi, yi, ni, m) ! if x is ouside the xi(1)-xi(ni) interval set deriv3=0.0 if (xx < xi(1) .or. xx > xi(ni)) then deriv3 = 0.0 +#ifndef _OPENACC stop "problems with finding the 2nd derivative" +#else + return +#endif end if ! a binary (bisectional) search to find i so that xi(i-1) < x < xi(i) @@ -4918,9 +5347,10 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte ,draft,kbcon,k22,up_massentru,up_massdetru,lambau) implicit none - character *(*), intent (in) :: draft + integer, intent (in) :: draft integer, intent(in):: itf,ktf, its,ite, kts,kte integer, intent(in) , dimension(its:ite) :: ierr,ktop,kbcon,k22 +!$acc declare copyin(ierr,ktop,kbcon,k22) !real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau real(kind=kind_phys), intent(inout), optional , dimension(its:ite):: lambau real(kind=kind_phys), intent(in) , dimension(its:ite,kts:kte) :: zo_cup,zuo @@ -4929,10 +5359,13 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte ,up_massentr, up_massdetr real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte), optional :: & up_massentru,up_massdetru +!$acc declare copy(lambau,cd,entr_rate_2d) copyin(zo_cup,zuo) copyout(up_massentro, up_massdetro,up_massentr, up_massdetr) +!$acc declare copyout(up_massentro, up_massdetro,up_massentr, up_massdetr, up_massentru,up_massdetru) !-- local vars integer :: i,k, incr1,incr2,turn real(kind=kind_phys) :: dz,trash,trash2 +!$acc kernels do k=kts,kte do i=its,ite up_massentro(i,k)=0. @@ -4941,17 +5374,22 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte up_massdetr (i,k)=0. enddo enddo +!$acc end kernels if(present(up_massentru) .and. present(up_massdetru))then +!$acc kernels do k=kts,kte do i=its,ite up_massentru(i,k)=0. up_massdetru(i,k)=0. enddo enddo +!$acc end kernels endif +!$acc parallel loop do i=its,itf if(ierr(i).eq.0)then - + +!$acc loop private(dz) do k=max(2,k22(i)+1),maxloc(zuo(i,:),1) !=> below maximum value zu -> change entrainment dz=zo_cup(i,k)-zo_cup(i,k-1) @@ -4965,6 +5403,7 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte endif if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1)) enddo +!$acc loop private(dz) do k=maxloc(zuo(i,:),1)+1,ktop(i) !=> above maximum value zu -> change detrainment dz=zo_cup(i,k)-zo_cup(i,k-1) @@ -4989,8 +5428,12 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte do k=2,ktf-1 up_massentr (i,k-1)=up_massentro(i,k-1) up_massdetr (i,k-1)=up_massdetro(i,k-1) - enddo - if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'deep')then + enddo +! Dan: draft +! deep = 1 +! shallow = 2 +! mid = 3 + if(present(up_massentru) .and. present(up_massdetru) .and. draft == 1)then !turn=maxloc(zuo(i,:),1) !do k=2,turn ! up_massentru(i,k-1)=up_massentro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) @@ -5001,12 +5444,12 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) enddo - else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'shallow')then + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 2)then do k=2,ktf-1 up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) enddo - else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'mid')then + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 3)then lambau(i)=0. do k=2,ktf-1 up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) @@ -5025,6 +5468,7 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte endif enddo +!$acc end parallel end subroutine get_lateral_massflux !---meltglac------------------------------------------------- !------------------------------------------------------------------------------------ @@ -5036,17 +5480,23 @@ subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer integer ,intent (in ) :: itf,ktf, its,ite, kts,kte real(kind=kind_phys), intent (in ), dimension(its:ite,kts:kte) :: tn,po_cup real(kind=kind_phys), intent (inout), dimension(its:ite,kts:kte) :: p_liq_ice,melting_layer +!$acc declare copyin(tn,po_cup) copy(p_liq_ice,melting_layer) integer , intent (in ), dimension(its:ite) :: ierr +!$acc declare copyin(ierr) integer :: i,k real(kind=kind_phys) :: dp - real(kind=kind_phys), dimension(its:ite) :: norm + real(kind=kind_phys), dimension(its:ite) :: norm +!$acc declare create(norm) real(kind=kind_phys), parameter :: t1=276.16 ! hli initialize at the very beginning +!$acc kernels p_liq_ice (:,:) = 1. melting_layer(:,:) = 0. +!$acc end kernels !-- get function of t for partition of total condensate into liq and ice phases. if(melt_glac .and. cumulus == 'deep') then +!$acc kernels do i=its,itf if(ierr(i).eq.0)then do k=kts,ktf @@ -5089,8 +5539,10 @@ subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer !do k=kts,ktf do i=its,itf if(ierr(i).eq.0)then +!$acc loop independent do k=kts,ktf-1 dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) +!$acc atomic update norm(i) = norm(i) + melting_layer(i,k)*dp/g enddo endif @@ -5111,10 +5563,12 @@ subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer ! !print*,"n=",i,k,norm(i) ! enddo ! enddo - +!$acc end kernels else +!$acc kernels p_liq_ice (:,:) = 1. melting_layer(:,:) = 0. +!$acc end kernels endif end subroutine get_partition_liq_ice @@ -5131,13 +5585,15 @@ subroutine get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco real(kind=kind_phys) ,intent (in ), dimension(its:ite,kts:kte) :: tn_cup,po_cup,qrco,pwo & ,pwdo,p_liq_ice,melting_layer real(kind=kind_phys) ,intent (inout), dimension(its:ite,kts:kte) :: melting +!$acc declare copyin(ierr,edto,tn_cup,po_cup,qrco,pwo,pwdo,p_liq_ice,melting_layer,melting) integer :: i,k real(kind=kind_phys) :: dp real(kind=kind_phys), dimension(its:ite) :: norm,total_pwo_solid_phase real(kind=kind_phys), dimension(its:ite,kts:kte) :: pwo_solid_phase,pwo_eff +!$acc declare create(norm,total_pwo_solid_phase,pwo_solid_phase,pwo_eff) if(melt_glac .and. cumulus == 'deep') then - +!$acc kernels !-- set melting mixing ratio to zero for columns that do not have deep convection do i=its,itf if(ierr(i) > 0) melting(i,:) = 0. @@ -5185,10 +5641,12 @@ subroutine get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco ! print*,"cons=",i,norm(i),total_pwo_solid_phase(i) ! enddo !-- - +!$acc end kernels else +!$acc kernels !-- no melting allowed in this run melting (:,:) = 0. +!$acc end kernels endif end subroutine get_melting_profile !---meltglac------------------------------------------------- @@ -5203,12 +5661,15 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo integer, dimension (its:ite),intent (in) :: kstabi,k22,kbcon,kpbl,klcl integer, dimension (its:ite),intent (inout) :: ierr,ktop +!$acc declare copy(entr_rate_2d,zuo,ierr,ktop) copyin(p_cup, heo,heso_cup,z_cup,hkbo,kstabi,k22,kbcon,kpbl,klcl) real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot +!$acc declare create(hcot) character *(*), intent (in) :: name real(kind=kind_phys) :: dz,dh, dbythresh real(kind=kind_phys) :: dby(kts:kte) integer :: i,k,ipr,kdefi,kstart,kbegzu,kfinalzu integer, dimension (its:ite) :: start_level +!$acc declare create(start_level) integer,parameter :: find_ktop_option = 1 !0=original, 1=new dbythresh=0.8 !0.95 ! the range of this parameter is 0-1, higher => lower @@ -5219,6 +5680,7 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c dbythresh=1.0 endif ! print*,"================================cumulus=",name; call flush(6) +!$acc parallel loop private(dby,kfinalzu,dz) do i=its,itf kfinalzu=ktf-2 ktop(i)=kfinalzu @@ -5233,7 +5695,7 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c dby(start_level(i))=(hcot(i,start_level(i))-heso_cup(i,start_level(i)))*dz !print*,'hco1=',start_level(i),kbcon(i),hcot(i,start_level(i))/heso_cup(i,start_level(i)) - +!$acc loop seq do k=start_level(i)+1,ktf-2 dz=z_cup(i,k)-z_cup(i,k-1) @@ -5273,6 +5735,7 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c ! endif enddo +!$acc end parallel end subroutine get_cloud_top !------------------------------------------------------------------------------------ diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index f83f673ba..43e82a745 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -7,7 +7,7 @@ module cu_gf_driver ! DH* TODO: replace constants with arguments to cu_gf_driver_run !use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv use machine , only: kind_phys - use cu_gf_deep, only: cu_gf_deep_run,neg_check,fct1d3 + use cu_gf_deep, only: cu_gf_deep_run,neg_check,autoconv,aeroevap,fct1d3 use cu_gf_sh , only: cu_gf_sh_run implicit none @@ -40,11 +40,14 @@ subroutine cu_gf_driver_init(imfshalcnv, imfshalcnv_gf, imfdeepcnv, & 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 + ! 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 @@ -116,15 +119,19 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& logical, intent(in ) :: ldiag3d real(kind=kind_phys), intent(inout) :: dtend(:,:,:) +!$acc declare copy(dtend) integer, intent(in) :: dtidx(:,:), & index_of_x_wind, index_of_y_wind, index_of_temperature, & index_of_process_scnv, index_of_process_dcnv, ntqv, ntcw, ntiw - +!$acc declare copyin(dtidx) real(kind=kind_phys), dimension( : , : ), intent(in ) :: forcet,forceqv_spechum,w,phil real(kind=kind_phys), dimension( : , : ), intent(inout ) :: t,us,vs real(kind=kind_phys), dimension( : , : ), intent(inout ) :: qci_conv real(kind=kind_phys), dimension( : , : ), intent(out ) :: cnvw_moist,cnvc real(kind=kind_phys), dimension( : , : ), intent(inout ) :: cliw, clcw +!$acc declare copyin(forcet,forceqv_spechum,w,phil) +!$acc declare copy(t,us,vs,qci_conv,cliw, clcw) +!$acc declare copyout(cnvw_moist,cnvc) real(kind=kind_phys), allocatable :: clcw_save(:,:), cliw_save(:,:) @@ -132,28 +139,38 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& real(kind=kind_phys), intent(in) :: fhour, fh_dfi_radar(:) integer, intent(in) :: num_dfi_radar, ix_dfi_radar(:) real(kind=kind_phys), intent(in) :: cap_suppress(:,:) +!$acc declare copyin(fh_dfi_radar,ix_dfi_radar,cap_suppress) integer, dimension (:), intent(out) :: hbot,htop,kcnv integer, dimension (:), intent(in) :: xland real(kind=kind_phys), dimension (:), intent(in) :: pbl +!$acc declare copyout(hbot,htop,kcnv) +!$acc declare copyin(xland,pbl) integer, dimension (im) :: tropics +!$acc declare create(tropics) ! ruc variable real(kind=kind_phys), dimension (:), intent(in) :: hfx2,qfx2,psuri real(kind=kind_phys), dimension (:,:), intent(out) :: ud_mf,dd_mf,dt_mf real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d real(kind=kind_phys), dimension (:,:), intent(in) :: t2di,p2di +!$acc declare copyin(hfx2,qfx2,psuri,t2di,p2di) +!$acc declare copyout(ud_mf,dd_mf,dt_mf,raincv,cld1d) ! Specific humidity from FV3 real(kind=kind_phys), dimension (:,:), intent(in) :: qv2di_spechum real(kind=kind_phys), dimension (:,:), intent(inout) :: qv_spechum real(kind=kind_phys), dimension (:), intent(inout) :: aod_gf +!$acc declare copyin(qv2di_spechum) copy(qv_spechum,aod_gf) ! Local water vapor mixing ratios and cloud water mixing ratios real(kind=kind_phys), dimension (im,km) :: qv2di, qv, forceqv, cnvw +!$acc declare create(qv2di, qv, forceqv, cnvw) ! real(kind=kind_phys), dimension(:),intent(in) :: garea +!$acc declare copyin(garea) real(kind=kind_phys), intent(in ) :: dt integer, intent(in ) :: imfshalcnv integer, dimension(:), intent(inout) :: cactiv,cactiv_m +!$acc declare copy(cactiv,cactiv_m) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -182,11 +199,23 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, dimension (im) :: kbcon, ktop,ierr,ierrs,ierrm,kpbli integer, dimension (im) :: k22s,kbcons,ktops,k22,jmin,jminm integer, dimension (im) :: kbconm,ktopm,k22m +!$acc declare create(k22_shallow,kbcon_shallow,ktop_shallow,rand_mom,rand_vmas, & +!$acc rand_clos,gdc,gdc2,ht,ccn_gf,ccn_m,dx,frhm,frhd, & +!$acc outt,outq,outqc,phh,subm,cupclw,cupclws, & +!$acc dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm, & +!$acc outts,outqs,outqcs,outu,outv,outus,outvs, & +!$acc outtm,outqm,outqcm,submm,cupclwm, & +!$acc cnvwt,cnvwts,cnvwtm,hco,hcdo,zdo,zdd,hcom,hcdom,zdom, & +!$acc tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi, & +!$acc pret,prets,pretm,hexec,forcing,forcing2, & +!$acc kbcon, ktop,ierr,ierrs,ierrm,kpbli, & +!$acc k22s,kbcons,ktops,k22,jmin,jminm,kbconm,ktopm,k22m) integer :: iens,ibeg,iend,jbeg,jend,n integer :: ibegh,iendh,jbegh,jendh integer :: ibegc,iendc,jbegc,jendc,kstop real(kind=kind_phys), dimension(im,km) :: rho_dryar +!$acc declare create(rho_dryar) real(kind=kind_phys) :: pten,pqen,paph,zrho,pahfs,pqhfl,zkhvfl,pgeoh integer, parameter :: ipn = 0 @@ -200,6 +229,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& real(kind=kind_phys), dimension (im) :: z1,psur,cuten,cutens,cutenm real(kind=kind_phys), dimension (im) :: umean,vmean,pmean real(kind=kind_phys), dimension (im) :: xmbs,xmbs2,xmb,xmbm,xmb_dumm,mconv +!$acc declare create(qcheck,zo,t2d,q2d,po,p2d,rhoi,clw_ten,tn,qo,tshall,qshall,dz8w,omeg, & +!$acc z1,psur,cuten,cutens,cutenm,umean,vmean,pmean, & +!$acc xmbs,xmbs2,xmb,xmbm,xmb_dumm,mconv) integer :: i,j,k,icldck,ipr,jpr,jpr_deep,ipr_deep,uidx,vidx,tidx,qidx integer :: itf,jtf,ktf,iss,jss,nbegin,nend,cliw_idx,clcw_idx @@ -209,6 +241,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& real(kind=kind_phys), dimension(km) :: massflx,trcflx_in1,clw_in1,po_cup ! real(kind=kind_phys), dimension(km) :: trcflx_in2,clw_in2,clw_ten2 real(kind=kind_phys), dimension (im) :: flux_tun,tun_rad_mid,tun_rad_shall,tun_rad_deep +!$acc declare create(flux_tun,tun_rad_mid,tun_rad_shall,tun_rad_deep) character*50 :: ierrc(im),ierrcm(im) character*50 :: ierrcs(im) ! ruc variable @@ -216,13 +249,16 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! qfx2 -- latent heat flux (kg/kg m/s), positive upward from sfc ! gf needs them in w/m2. define hfx and qfx after simple unit conversion real(kind=kind_phys), dimension (im) :: hfx,qfx +!$acc declare create(hfx,qfx) real(kind=kind_phys) tem,tem1,tf,tcr,tcrf real(kind=kind_phys) :: cliw_shal,clcw_shal,tem_shal, cliw_both, weight_sum real(kind=kind_phys) :: cliw_deep,clcw_deep,tem_deep, clcw_both integer :: cliw_deep_idx, clcw_deep_idx, cliw_shal_idx, clcw_shal_idx real(kind=kind_phys) :: cap_suppress_j(im) +!$acc declare create(cap_suppress_j) integer :: itime, do_cap_suppress_here + logical :: exit_func !parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) ! FV3 original !parameter (tf=263.16, tcr=273.16, tcrf=1.0/(tcr-tf)) @@ -233,19 +269,25 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& errflg = 0 if(do_cap_suppress) then +!$acc serial do itime=1,num_dfi_radar if(ix_dfi_radar(itime)<1) cycle if(fhour=fh_dfi_radar(itime+1)) cycle exit enddo +!$acc end serial endif if(do_cap_suppress .and. itime<=num_dfi_radar) then do_cap_suppress_here = 1 - cap_suppress_j = cap_suppress(:,itime) +!$acc kernels + cap_suppress_j(:) = cap_suppress(:,itime) +!$acc end kernels else do_cap_suppress_here = 0 - cap_suppress_j = 0 +!$acc kernels + cap_suppress_j(:) = 0 +!$acc end kernels endif if(ldiag3d) then @@ -266,14 +308,18 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& if(cliw_deep_idx>=1 .or. clcw_deep_idx>=1 .or. & cliw_shal_idx>=1 .or. clcw_shal_idx>=1) then allocate(clcw_save(im,km), cliw_save(im,km)) - clcw_save=clcw - cliw_save=cliw +!$acc enter data create(clcw_save,cliw_save) +!$acc kernels + clcw_save(:,:)=clcw(:,:) + cliw_save(:,:)=cliw(:,:) +!$acc end kernels endif endif ! ! Scale specific humidity to dry mixing ratio ! +!$acc kernels ! state in before physics qv2di = qv2di_spechum/(1.0_kind_phys-qv2di_spechum) ! forcing by dynamics, based on state in @@ -285,10 +331,10 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! these should be coming in from outside ! ! cactiv(:) = 0 -! cactiv_m(:) = 0 rand_mom(:) = 0. rand_vmas(:) = 0. rand_clos(:,:) = 0. +!$acc end kernels ! its=1 ite=im @@ -299,7 +345,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& kts=1 kte=km ktf=kte-1 -! +!$acc kernels +! tropics(:)=0 ! !> - Set tuning constants for radiation coupling @@ -316,6 +363,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! dx for scale awareness ! dx=40075000./float(lonf) ! tscl_kf=dx/25000. +!$acc end kernels if (imfshalcnv == 3) then ishallow_g3 = 1 @@ -342,13 +390,17 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ztq=0. hfm=0. qfm=0. - ud_mf =0. - dd_mf =0. - dt_mf =0. +!$acc kernels + ud_mf(:,:) =0. + dd_mf(:,:) =0. + dt_mf(:,:) =0. tau_ecmwf(:)=0. +!$acc end kernels ! j=1 +!$acc kernels ht(:)=phil(:,1)/g +!$acc loop private(zh) do i=its,ite cld1d(i)=0. zo(i,:)=phil(i,:)/g @@ -358,6 +410,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& do k=kts+1,ktf dz8w(i,k)=zo(i,k+1)-zo(i,k) enddo +!$acc loop seq do k=kts+1,ktf zh(k)=zh(k-1)+dz8w(i,k-1) if(zh(k).gt.pbl(i))then @@ -366,7 +419,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& endif enddo enddo +!$acc end kernels +!$acc kernels do i= its,itf forcing(i,:)=0. forcing2(i,:)=0. @@ -434,7 +489,10 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& cuten(:)=0. cutenm(:)=0. cutens(:)=0. +!$acc end kernels ierrc(:)=" " +!$acc kernels + kbcon(:)=0 kbcons(:)=0 @@ -516,7 +574,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& qshall(i,k)=q2d(i,k) enddo enddo +!$acc end kernels 123 format(1x,i2,1x,2(1x,f8.0),1x,2(1x,f8.3),3(1x,e13.5)) +!$acc kernels do i=its,itf do k=kts,kpbli(i) tshall(i,k)=t(i,k) @@ -549,12 +609,16 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! qshall(i,k)=qv(i,k) enddo enddo +!$acc loop collapse(2) independent private(dp) do k= kts+1,ktf-1 do i = its,itf if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then dp=-.5*(p2d(i,k+1)-p2d(i,k-1)) +!$acc atomic umean(i)=umean(i)+us(i,k)*dp +!$acc atomic vmean(i)=vmean(i)+vs(i,k)*dp +!$acc atomic pmean(i)=pmean(i)+dp endif enddo @@ -569,15 +633,18 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& do i = its,itf if(mconv(i).lt.0.)mconv(i)=0. enddo +!$acc end kernels ! !---- call cumulus parameterization ! if(ishallow_g3.eq.1)then +!$acc kernels do i=its,ite ierrs(i)=0 ierrm(i)=0 enddo +!$acc end kernels ! !> - Call shallow: cu_gf_sh_run() ! @@ -593,10 +660,11 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! dimesnional variables itf,ktf,its,ite, kts,kte,ipr,tropics) - +!$acc kernels do i=its,itf if(xmbs(i).gt.0.)cutens(i)=1. enddo +!$acc end kernels !> - Call neg_check() for GF shallow convection call neg_check('shallow',ipn,dt,qcheck,outqs,outts,outus,outvs, & outqcs,prets,its,ite,kts,kte,itf,ktf,ktops) @@ -673,12 +741,13 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,do_cap_suppress_here,cap_suppress_j & ,k22m & ,jminm,tropics) - +!$acc kernels do i=its,itf do k=kts,ktf qcheck(i,k)=qv(i,k) +outqs(i,k)*dt enddo enddo +!$acc end kernels !> - Call neg_check() for middle GF convection call neg_check('mid',ipn,dt,qcheck,outqm,outtm,outum,outvm, & outqcm,pretm,its,ite,kts,kte,itf,ktf,ktopm) @@ -756,11 +825,13 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,jmin,tropics) jpr=0 ipr=0 +!$acc kernels do i=its,itf do k=kts,ktf qcheck(i,k)=qv(i,k) +(outqs(i,k)+outqm(i,k))*dt enddo enddo +!$acc end kernels !> - Call neg_check() for deep GF convection call neg_check('deep',ipn,dt,qcheck,outq,outt,outu,outv, & outqc,pret,its,ite,kts,kte,itf,ktf,ktop) @@ -785,6 +856,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! cutenm(i)=0. ! endif ! pret > 0 ! enddo +!$acc kernels do i=its,itf kcnv(i)=0 if(pretm(i).gt.0.)then @@ -809,7 +881,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& cuten(i)=0. endif ! pret > 0 enddo +!$acc end kernels ! +!$acc parallel loop private(kstop,dtime_max,massflx,trcflx_in1,clw_in1,po_cup) do i=its,itf massflx(:)=0. trcflx_in1(:)=0. @@ -942,6 +1016,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) endif enddo +!$acc end parallel +!$acc kernels do i=its,itf if(pret(i).gt.0.)then cactiv(i)=1 @@ -974,12 +1050,15 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ccn_gf(i)=(aod_gf(i)/0.0027)**(1/0.640) endif enddo +!$acc end kernels 100 continue ! ! Scale dry mixing ratios for water wapor and cloud water to specific humidy / moist mixing ratios ! +!$acc kernels qv_spechum = qv/(1.0_kind_phys+qv) cnvw_moist = cnvw/(1.0_kind_phys+qv) +!$acc end kernels ! ! Diagnostic tendency updates ! @@ -990,21 +1069,28 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& tidx=dtidx(index_of_temperature,index_of_process_scnv) qidx=dtidx(100+ntqv,index_of_process_scnv) if(uidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,uidx) = dtend(:,k,uidx) + cutens(:)*outus(:,k) * dt enddo +!$acc end kernels endif if(vidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,vidx) = dtend(:,k,vidx) + cutens(:)*outvs(:,k) * dt enddo +!$acc end kernels endif if(tidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,tidx) = dtend(:,k,tidx) + cutens(:)*outts(:,k) * dt enddo +!$acc end kernels endif if(qidx>=1) then +!$acc kernels do k=kts,ktf do i=its,itf tem = cutens(i)*outqs(i,k)* dt @@ -1012,6 +1098,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& dtend(i,k,qidx) = dtend(i,k,qidx) + tem enddo enddo +!$acc end kernels endif endif if((ideep.eq.1. .or. imid_gf.eq.1) .and. .not.flag_for_dcnv_generic_tend) then @@ -1019,23 +1106,30 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& vidx=dtidx(index_of_y_wind,index_of_process_dcnv) tidx=dtidx(index_of_temperature,index_of_process_dcnv) if(uidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,uidx) = dtend(:,k,uidx) + (cuten*outu(:,k)+cutenm*outum(:,k)) * dt enddo +!$acc end kernels endif if(vidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,vidx) = dtend(:,k,vidx) + (cuten*outv(:,k)+cutenm*outvm(:,k)) * dt enddo +!$acc end kernels endif if(tidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,tidx) = dtend(:,k,tidx) + (cuten*outt(:,k)+cutenm*outtm(:,k)) * dt enddo +!$acc end kernels endif qidx=dtidx(100+ntqv,index_of_process_dcnv) if(qidx>=1) then +!$acc kernels do k=kts,ktf do i=its,itf tem = (cuten(i)*outq(i,k) + cutenm(i)*outqm(i,k))* dt @@ -1043,9 +1137,11 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& dtend(i,k,qidx) = dtend(i,k,qidx) + tem enddo enddo +!$acc end kernels endif endif if(allocated(clcw_save)) then +!$acc parallel loop collapse(2) private(tem_shal,tem_deep,tem,tem1,weight_sum,cliw_both,clcw_both) do k=kts,ktf do i=its,itf tem_shal = dt*(outqcs(i,k)*cutens(i)+outqcm(i,k)*cutenm(i)) @@ -1078,6 +1174,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& endif enddo enddo +!$acc end parallel endif endif end subroutine cu_gf_driver_run diff --git a/physics/cu_gf_driver_post.F90 b/physics/cu_gf_driver_post.F90 index eab5eefd6..b9fafc4df 100644 --- a/physics/cu_gf_driver_post.F90 +++ b/physics/cu_gf_driver_post.F90 @@ -37,6 +37,7 @@ subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, co real(kind_phys), intent(out) :: conv_act(:) real(kind_phys), intent(out) :: conv_act_m(:) character(len=*), intent(out) :: errmsg +!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) integer, intent(out) :: errflg ! Local variables @@ -46,6 +47,7 @@ subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, co errmsg = '' errflg = 0 +!$acc kernels prevst(:,:) = t(:,:) prevsq(:,:) = q(:,:) @@ -61,6 +63,7 @@ subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, co conv_act_m(i)=0.0 endif enddo +!$acc end kernels end subroutine cu_gf_driver_post_run diff --git a/physics/cu_gf_driver_pre.F90 b/physics/cu_gf_driver_pre.F90 index 4d4ae9162..58dc0414a 100644 --- a/physics/cu_gf_driver_pre.F90 +++ b/physics/cu_gf_driver_pre.F90 @@ -37,12 +37,15 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, real(kind_phys), intent(in) :: q(:,:) real(kind_phys), intent(in) :: prevst(:,:) real(kind_phys), intent(in) :: prevsq(:,:) +!$acc declare copyin(t,q,prevst,prevsq) real(kind_phys), intent(out) :: forcet(:,:) real(kind_phys), intent(out) :: forceq(:,:) integer, intent(out) :: cactiv(:) integer, intent(out) :: cactiv_m(:) +!$acc declare copyout(forcet,forceq,cactiv,cactiv_m) real(kind_phys), intent(in) :: conv_act(:) real(kind_phys), intent(in) :: conv_act_m(:) +!$acc declare copyin(conv_act,conv_act_m) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -57,21 +60,29 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, ! are read from the restart files beforehand, same ! for conv_act. if(flag_init .and. .not.flag_restart) then +!$acc kernels forcet(:,:)=0.0 forceq(:,:)=0.0 +!$acc end kernels else dtdyn=3600.0*(fhour)/kdt if(dtp > dtdyn) then +!$acc kernels forcet(:,:)=(t(:,:) - prevst(:,:))/dtp forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp +!$acc end kernels else +!$acc kernels forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn +!$acc end kernels endif endif +!$acc kernels cactiv(:)=nint(conv_act(:)) cactiv_m(:)=nint(conv_act_m(:)) +!$acc end kernels end subroutine cu_gf_driver_pre_run diff --git a/physics/cu_gf_sh.F90 b/physics/cu_gf_sh.F90 index e30ca95bc..b9a723856 100644 --- a/physics/cu_gf_sh.F90 +++ b/physics/cu_gf_sh.F90 @@ -91,6 +91,7 @@ subroutine cu_gf_sh_run ( & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv +!$acc declare copy(cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv) real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & xmb_out @@ -103,6 +104,7 @@ subroutine cu_gf_sh_run ( & integer, dimension (its:ite) & ,intent (in ) :: & kpbl,tropics +!$acc declare copyout(xmb_out,kbcon,ktop,k22) copyin(kpbl,tropics) copy(ierr) ! ! basic environmental input includes a flag (ierr) to turn off ! convection for this call only and at that particular gridpoint @@ -120,6 +122,7 @@ subroutine cu_gf_sh_run ( & real(kind=kind_phys) & ,intent (in ) :: & dtime,tcrit +!$acc declare copyin(t,po,tn,dhdt,rho,us,vs) copy(q,qo) copyin(xland,z1,psur,hfx,qfx) copyin(dtime,tcrit) ! !***************** the following are your basic environmental ! variables. they carry a "_cup" if they are @@ -179,6 +182,19 @@ subroutine cu_gf_sh_run ( & cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup +!$acc declare create( & +!$acc entr_rate_2d,he,hes,qes,z, & +!$acc heo,heso,qeso,zo, & +!$acc xhe,xhes,xqes,xz,xt,xq, & +!$acc qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & +!$acc qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup, & +!$acc tn_cup, & +!$acc xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & +!$acc xt_cup,dby,hc,zu, & +!$acc dbyo,qco,pwo,hco,qrco, & +!$acc dbyt,xdby,xhc,xzu, & +!$acc cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup) + ! aa0 cloud work function for downdraft ! aa0 = cloud work function without forcing effects ! aa1 = cloud work function with forcing effects @@ -192,6 +208,13 @@ subroutine cu_gf_sh_run ( & cap_max_increment,lambau integer, dimension (its:ite) :: & kstabi,xland1,kbmax,ktopx +!$acc declare create( & +!$acc zws,ztexec,zqexec,pre,aa1,aa0,xaa0,hkb, & +!$acc flux_tun,hkbo,xhkb, & +!$acc rand_vmas,xmbmax,xmb, & +!$acc cap_max,entr_rate, & +!$acc cap_max_increment,lambau, & +!$acc kstabi,xland1,kbmax,ktopx) integer :: & kstart,i,k,ki @@ -205,15 +228,24 @@ subroutine cu_gf_sh_run ( & character*50 :: ierrc(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: & up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru +!$acc declare create(up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru) real(kind=kind_phys) :: c_up,x_add,qaver,dts,fp,fpi real(kind=kind_phys), dimension (its:ite,kts:kte) :: c1d,dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers integer, dimension (its:ite) :: start_level, pmin_lev +!$acc declare create(c1d,dtempdz,k_inv_layers,start_level, pmin_lev) + + real(kind=kind_phys), parameter :: zero = 0 + +!$acc kernels start_level(:)=0 rand_vmas(:)=0. - flux_tun=fluxtune + flux_tun(:)=fluxtune lambau(:)=2. c1d(:,:)=0. +!$acc end kernels + +!$acc kernels do i=its,itf xland1(i)=int(xland(i)+.001) ! 1. ktopx(i)=0 @@ -224,9 +256,13 @@ subroutine cu_gf_sh_run ( & pre(i)=0. xmb_out(i)=0. cap_max_increment(i)=25. - ierrc(i)=" " entr_rate(i) = 1.e-3 !9.e-5 ! 1.75e-3 ! 1.2e-3 ! .2/50. enddo +!$acc end kernels + + do i=its,itf + ierrc(i)=" " + enddo ! !--- initial entrainment rate (these may be changed later on in the !--- program @@ -235,6 +271,7 @@ subroutine cu_gf_sh_run ( & ! !--- initial detrainmentrates ! +!$acc kernels do k=kts,ktf do i=its,itf up_massentro(i,k)=0. @@ -250,6 +287,7 @@ subroutine cu_gf_sh_run ( & cupclw(i,k)=0. enddo enddo +!$acc end kernels ! !--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft ! @@ -259,6 +297,7 @@ subroutine cu_gf_sh_run ( & !--- maximum depth (mb) of capping !--- inversion (larger cap = no convection) ! +!$acc kernels cap_maxs=175. do i=its,itf kbmax(i)=1 @@ -292,7 +331,7 @@ subroutine cu_gf_sh_run ( & zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct enddo - +!$acc end kernels ! !> - Determin max height(m) above ground where updraft air can originate ! @@ -322,6 +361,8 @@ subroutine cu_gf_sh_run ( & ierr,z1, & itf,ktf, & its,ite, kts,kte) + +!$acc kernels do i=its,itf if(ierr(i).eq.0)then u_cup(i,kts)=us(i,kts) @@ -336,6 +377,7 @@ subroutine cu_gf_sh_run ( & do i=its,itf if(ierr(i).eq.0)then ! +!$acc loop seq do k=kts,ktf if(zo_cup(i,k).gt.zkbmax+z1(i))then kbmax(i)=k @@ -347,12 +389,14 @@ subroutine cu_gf_sh_run ( & kbmax(i)=min(kbmax(i),ktf/2) endif enddo +!$acc end kernels ! ! ! !> - Determine level with highest moist static energy content (\p k22) ! +!$acc parallel loop do 36 i=its,itf if(kpbl(i).gt.3)cap_max(i)=po_cup(i,kpbl(i)) if(ierr(i) == 0)then @@ -360,17 +404,21 @@ subroutine cu_gf_sh_run ( & k22(i)=max(2,k22(i)) if(k22(i).gt.kbmax(i))then ierr(i)=2 +#ifndef _OPENACC ierrc(i)="could not find k22" +#endif ktop(i)=0 k22(i)=0 kbcon(i)=0 endif endif 36 continue +!$acc end parallel ! !> - Call get_cloud_bc() and cup_kbcon() to determine the level of !! convective cloud base (\p kbcon) ! +!$acc parallel loop private(x_add) do i=its,itf if(ierr(i).eq.0)then x_add = xlv*zqexec(i)+cp*ztexec(i) @@ -378,13 +426,17 @@ subroutine cu_gf_sh_run ( & call get_cloud_bc(kte,heo_cup(i,1:kte),hkbo(i),k22(i),x_add) endif ! ierr enddo +!$acc end parallel !joe-georg and saulo's new idea: + +!$acc kernels do i=its,itf do k=kts,ktf dbyo(i,k)= 0. !hkbo(i)-heso_cup(i,k) enddo enddo +!$acc end kernels call cup_kbcon(ierrc,cap_max_increment,5,k22,kbcon,heo_cup,heso_cup, & @@ -403,6 +455,7 @@ subroutine cu_gf_sh_run ( & kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) ! ! +!$acc parallel loop private(frh,kstart,x_add) do i=its,itf entr_rate_2d(i,:)=entr_rate(i) if(ierr(i) == 0)then @@ -438,9 +491,11 @@ subroutine cu_gf_sh_run ( & endif endif enddo +!$acc end parallel !> - Call rates_up_pdf() to get normalized mass flux profile call rates_up_pdf(rand_vmas,ipr,'shallow',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopx,kbcon,pmin_lev) +!$acc kernels do i=its,itf if(ierr(i).eq.0)then ! do k=maxloc(zuo(i,:),1),1,-1 ! ktop(i)-1,1,-1 @@ -451,22 +506,26 @@ subroutine cu_gf_sh_run ( & ! endif ! enddo if(k22(i).gt.1)then +!$acc loop independent do k=1,k22(i)-1 zuo(i,k)=0. zu (i,k)=0. xzu(i,k)=0. enddo endif +!$acc loop seq do k=maxloc(zuo(i,:),1),ktop(i) if(zuo(i,k).lt.1.e-6)then ktop(i)=k-1 exit endif enddo +!$acc loop independent do k=k22(i),ktop(i) xzu(i,k)= zuo(i,k) zu(i,k)= zuo(i,k) enddo +!$acc loop independent do k=ktop(i)+1,ktf zuo(i,k)=0. zu (i,k)=0. @@ -475,14 +534,15 @@ subroutine cu_gf_sh_run ( & k22(i)=max(2,k22(i)) endif enddo +!$acc end kernels ! !> - Call get_lateral_massflux() to calculate mass entrainment and detrainment ! call get_lateral_massflux(itf,ktf, its,ite, kts,kte & ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & ,up_massentro, up_massdetro ,up_massentr, up_massdetr & - ,'shallow',kbcon,k22,up_massentru,up_massdetru,lambau) - + ,2,kbcon,k22,up_massentru,up_massdetru,lambau) +!$acc kernels do k=kts,ktf do i=its,itf hc(i,k)=0. @@ -507,11 +567,15 @@ subroutine cu_gf_sh_run ( & hc(i,k)=hkb(i) hco(i,k)=hkbo(i) enddo +!$acc end kernels ! ! + +!$acc parallel loop private(ki,qaver,k,trash,trash2,dz,dp) do 42 i=its,itf dbyt(i,:)=0. if(ierr(i) /= 0) cycle +!$acc loop seq do k=start_level(i)+1,ktop(i) hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & up_massentr(i,k-1)*he(i,k-1)) / & @@ -547,16 +611,20 @@ subroutine cu_gf_sh_run ( & if(ktop(i).lt.kbcon(i)+1)then ierr(i)=5 +#ifndef _OPENACC ierrc(i)='ktop is less than kbcon+1' +#endif go to 42 endif if(ktop(i).gt.ktf-2)then ierr(i)=5 +#ifndef _OPENACC ierrc(i)="ktop is larger than ktf-2" +#endif go to 42 endif ! - call get_cloud_bc(kte,qo_cup (i,1:kte),qaver,k22(i)) + call get_cloud_bc(kte,qo_cup (i,1:kte),qaver,k22(i),zero) qaver = qaver + zqexec(i) do k=1,start_level(i)-1 qco (i,k)= qo_cup(i,k) @@ -564,6 +632,7 @@ subroutine cu_gf_sh_run ( & k=start_level(i) qco (i,k)= qaver ! +!$acc loop seq do k=start_level(i)+1,ktop(i) trash=qeso_cup(i,k)+(1./xlv)*(gammao_cup(i,k) & /(1.+gammao_cup(i,k)))*dbyo(i,k) @@ -593,15 +662,21 @@ subroutine cu_gf_sh_run ( & enddo trash=0. trash2=0. +!$acc loop independent do k=k22(i)+1,ktop(i) dp=100.*(po_cup(i,k)-po_cup(i,k+1)) cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp +!$acc atomic trash2=trash2+entr_rate_2d(i,k) +!$acc atomic qco(i,k)=qco(i,k)-qrco(i,k) enddo +!$acc loop independent do k=k22(i)+1,max(kbcon(i),k22(i)+1) +!$acc atomic trash=trash+entr_rate_2d(i,k) enddo +!$acc loop independent do k=ktop(i)+1,ktf-1 hc (i,k)=hes_cup (i,k) hco (i,k)=heso_cup(i,k) @@ -616,6 +691,7 @@ subroutine cu_gf_sh_run ( & zuo (i,k)=0. enddo 42 continue +!$acc end parallel ! !--- calculate workfunctions for updrafts ! @@ -626,14 +702,18 @@ subroutine cu_gf_sh_run ( & call cup_up_aa0(aa1,zo,zuo,dbyo,gammao_cup,tn_cup, & kbcon,ktop,ierr, & itf,ktf, its,ite, kts,kte) +!$acc kernels do i=its,itf if(ierr(i) == 0)then if(aa1(i) <= 0.)then ierr(i)=17 +#ifndef _OPENACC ierrc(i)="cloud work function zero" +#endif endif endif enddo +!$acc end kernels endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -643,6 +723,7 @@ subroutine cu_gf_sh_run ( & ! !--- 1. in bottom layer ! +!$acc kernels do k=kts,kte do i=its,itf dellah(i,k)=0. @@ -652,6 +733,7 @@ subroutine cu_gf_sh_run ( & dellv (i,k)=0. enddo enddo +!$acc end kernels ! !---------------------------------------------- cloud level ktop ! @@ -692,6 +774,8 @@ subroutine cu_gf_sh_run ( & ! !- - - - - - - - - - - - - - - - - - - - - - - - model level 1 trash2=0. +!$acc kernels +!$acc loop independent do i=its,itf if(ierr(i).eq.0)then dp=100.*(po_cup(i,1)-po_cup(i,2)) @@ -706,10 +790,12 @@ subroutine cu_gf_sh_run ( & entup=up_massentro(i,k) detup=up_massdetro(i,k) totmas=detup-entup+zuo(i,k+1)-zuo(i,k) +#ifndef _OPENACC if(abs(totmas).gt.1.e-6)then write(0,*)'*********************',i,k,totmas write(0,*)k22(i),kbcon(i),ktop(i) endif +#endif dp=100.*(po_cup(i,k)-po_cup(i,k+1)) dellah(i,k) =-(zuo(i,k+1)*(hco(i,k+1)-heo_cup(i,k+1) )- & zuo(i,k )*(hco(i,k )-heo_cup(i,k ) ))*g/dp @@ -741,12 +827,13 @@ subroutine cu_gf_sh_run ( & enddo endif enddo +!$acc end kernels ! !--- using dellas, calculate changed environmental profiles ! mbdt=.5 !3.e-4 - +!$acc kernels do k=kts,ktf do i=its,itf dellat(i,k)=0. @@ -767,6 +854,7 @@ subroutine cu_gf_sh_run ( & xt(i,ktf)=tn(i,ktf) endif enddo +!$acc end kernels ! ! if(make_calc_for_xk) then @@ -788,12 +876,16 @@ subroutine cu_gf_sh_run ( & ! ! !**************************** static control +!$acc kernels do k=kts,ktf do i=its,itf xhc(i,k)=0. xdby(i,k)=0. enddo enddo +!$acc end kernels + +!$acc parallel loop private(x_add) do i=its,itf if(ierr(i).eq.0)then x_add = xlv*zqexec(i)+cp*ztexec(i) @@ -805,17 +897,21 @@ subroutine cu_gf_sh_run ( & xhc(i,k)=xhkb(i) endif !ierr enddo +!$acc end parallel ! ! +!$acc kernels do i=its,itf if(ierr(i).eq.0)then xzu(i,1:ktf)=zuo(i,1:ktf) +!$acc loop seq do k=start_level(i)+1,ktop(i) xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1)+ & up_massentro(i,k-1)*xhe(i,k-1)) / & (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) xdby(i,k)=xhc(i,k)-xhes_cup(i,k) enddo +!$acc loop independent do k=ktop(i)+1,ktf xhc (i,k)=xhes_cup(i,k) xdby(i,k)=0. @@ -823,6 +919,7 @@ subroutine cu_gf_sh_run ( & enddo endif enddo +!$acc end kernels ! !--- workfunctions for updraft @@ -837,6 +934,8 @@ subroutine cu_gf_sh_run ( & ! ! now for shallow forcing ! +!$acc kernels +!$acc loop private(xff_shal) do i=its,itf xmb(i)=0. xff_shal(1:3)=0. @@ -870,7 +969,9 @@ subroutine cu_gf_sh_run ( & if(ichoice > 0)xmb(i)=min(xmbmax(i),xff_shal(ichoice)) if(xmb(i) <= 0.)then ierr(i)=21 +#ifndef _OPENACC ierrc(i)="21" +#endif endif endif if(ierr(i).ne.0)then @@ -889,10 +990,12 @@ subroutine cu_gf_sh_run ( & ! final tendencies ! pre(i)=0. +!$acc loop independent do k=2,ktop(i) outt (i,k)= dellat (i,k)*xmb(i) outq (i,k)= dellaq (i,k)*xmb(i) outqc(i,k)= dellaqc(i,k)*xmb(i) +!$acc atomic pre (i) = pre(i)+pwo(i,k)*xmb(i) enddo outt (i,1)= dellat (i,1)*xmb(i) @@ -928,6 +1031,7 @@ subroutine cu_gf_sh_run ( & endif endif enddo +!$acc end kernels ! ! done shallow !--------------------------done------------------------------ From 1cd31f921668dce4ff6406176532dabf465e04c5 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 11 Feb 2022 18:48:29 +0000 Subject: [PATCH 110/212] 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 070a9cdea3980de5d936786d41d260efcc3644a5 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 11 Feb 2022 14:24:25 -0700 Subject: [PATCH 111/212] change units of surface_stochastic_weights_from_coupled_process from none to 1 to match change in fv3atm --- physics/GFS_rrtmg_pre.meta | 2 +- physics/GFS_surface_generic.meta | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 37cd8d17a..1eac8a571 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -532,7 +532,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 diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 6ad2953a6..28c88c5ea 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -310,7 +310,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 From 2c02bc58075828c1d72c5da66f7cdedccc2f38cb Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sat, 12 Feb 2022 19:13:28 -0600 Subject: [PATCH 112/212] 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 113/212] 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 114/212] 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 115/212] 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 308b0b38347d5460351f91b8648646e15a90f220 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Wed, 16 Feb 2022 16:45:21 +0000 Subject: [PATCH 116/212] Remove misplaced file. --- drag_suite.F90 | 1381 ------------------------------------------------ 1 file changed, 1381 deletions(-) delete mode 100755 drag_suite.F90 diff --git a/drag_suite.F90 b/drag_suite.F90 deleted file mode 100755 index 7fea98b13..000000000 --- a/drag_suite.F90 +++ /dev/null @@ -1,1381 +0,0 @@ -!> \File drag_suite.F90 -!! This file is the parameterization of orographic gravity wave -!! drag, mountain blocking, and form drag. - -!> This module contains the CCPP-compliant orographic gravity wave dray scheme. - module drag_suite - - contains - - subroutine drag_suite_init(gwd_opt, errmsg, errflg) - - integer, intent(in) :: gwd_opt - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Consistency checks - if (gwd_opt/=3 .and. gwd_opt/=33) then - write(errmsg,'(*(a))') "Logic error: namelist choice of gravity wave & - & drag is different from drag_suite scheme" - errflg = 1 - return - end if - end subroutine drag_suite_init - -! \defgroup GFS_ogwd GFS Orographic Gravity Wave Drag -!> \defgroup gfs_drag_suite GFS drag_suite Main -!! \brief This subroutine includes orographic gravity wave drag, mountain -!! blocking, and form drag. -!! -!> The time tendencies of zonal and meridional wind are altered to -!! include the effect of mountain induced gravity wave drag from -!! subgrid scale orography including convective breaking, shear -!! breaking and the presence of critical levels. -!! -!> \section arg_table_drag_suite_run Argument Table -!! \htmlinclude drag_suite_run.html -!! -!> \section gen_drag_suite GFS Orographic GWD Scheme General Algorithm -!! -# Calculate subgrid mountain blocking -!! -# Calculate orographic wave drag -!! -!! The NWP model gravity wave drag (GWD) scheme in the GFS has two -!! main components: how the surface stress is computed, and then how -!! that stress is distributed over a vertical column where it may -!! interact with the models momentum. Each of these depends on the -!! large scale environmental atmospheric state and assumptions about -!! the sub-grid scale processes. In Alpert GWD (1987) based on linear, -!! two-dimensional non-rotating, stably stratified flow over a mountain ridge, -!! sub-grid scale gravity wave motions are assumed which propagate away -!! from the mountain. Described in Alpert (1987), the flux measured over -!! a "low level" vertically averaged layer, in the atmosphere defines a base -!! level flux. "Low level" was taken to be the first 1/3 of the troposphere -!! in the 1987 implementation. This choice was meant to encompass a thick -!! low layer for vertical averages of the environmental (large scale) flow -!! quantities. The vertical momentum flux or gravity wave stress in a -!! grid box due to a single mountain is given as in Pierrehumbert, (1987) (PH): -!! -!! \f$ \tau = \frac {\rho \: U^{3}\: G(F_{r})} {\Delta X \; N } \f$ -!! -!! emetic \f$ \Delta X \f$ is a grid increment, N is the Brunt Viasala frequency -!! -!! -!! \f$ N(\sigma) = \frac{-g \: \sigma \: -!! \frac{\partial\Theta}{\partial\sigma}}{\Theta \:R \:T} \f$ -!! -!! The environmental variables are calculated from a mass weighted vertical -!! average over a base layer. G(Fr) is a monotonically increasing -!! function of Froude number, -!! -!! \f$ F_{r} = \frac{N h^{'}}{U} \f$ -!! -!! where U is the wind speed calculated as a mass weighted vertical average in -!! the base layer, and h', is the vertical displacement caused by the orography -!! variance. An effective mountain length for the gravity wave processes, -!! -!! \f$ l^{*} = \frac{\Delta X}{m} \f$ -!! -!! where m is the number of mountains in a grid box, can then -!! be defined to obtain the form of the base level stress -!! -!! -!! \f$ \tau = \frac {\rho \: U^{3} \: G(F_{r})} {N \;l^{*}} \f$ -!! -!! giving the stress induced from the surface in a model grid box. -!! PH gives the form for the function G(Fr) as -!! -!! -!! \f$ G(F_{r}) = \bar{G}\frac{F^{2}_{r}}{F^{2}_{r}\: + \:a^{2}} \f$ -!! -!! Where \f$ \bar{G} \f$ is an order unity non-dimensional saturation -!! flux set to 1 and 'a' is a function of the mountain aspect ratio also -!!set to 1 in the 1987 implementation of the GFS GWD. Typical values of -!! U=10m/s, N=0.01 1/s, l*=100km, and a=1, gives a flux of 1 Pascal and -!! if this flux is made to go to zero linearly with height then the -!! decelerations would be about 10/m/s/day which is consistent with -!! observations in PH. -!! -!! -!! In Kim, Moorthi, Alpert's (1998, 2001) GWD currently in GFS operations, -!! the GWD scheme has the same physical basis as in Alpert (1987) with the addition -!! of enhancement factors for the amplitude, G, and mountain shape details -!! in G(Fr) to account for effects from the mountain blocking. A factor, -!! E m', is an enhancement factor on the stress in the Alpert '87 scheme. -!! The E ranges from no enhancement to an upper limit of 3, E=E(OA)[1-3], -!! and is a function of OA, the Orographic Asymmetry defined in KA (1995) as -!! -!! Orographic Asymmetry (OA) = \f$ \frac{ \bar{x} \; - \; -!! \sum\limits_{j=1}^{N_{b}} x_{j} \; n_{j} }{\sigma_{x}} \f$ -!! -!! where Nb is the total number of bottom blocks in the mountain barrier, -!! \f$ \sigma_{x} \f$ is the standard deviation of the horizontal distance defined by -!! -!! \f$ \sigma_{x} = \sqrt{ \frac{\sum\limits_{j=1}^{N_{b}} -!! \; (x_{j} \; - \; \bar{x} )^2}{N_{x}} } \f$ -!! -!! -!! where Nx is the number of grid intervals for the large scale domain being -!! considered. So the term, E(OA)m'/ \f$ \Delta X \f$ in Kim's scheme represents -!! a multiplier on G shown in Alpert's eq (1), where m' is the number of mountains -!! in a sub-grid scale box. Kim increased the complexity of m' making it a -!! function of the fractional area of the sub-grid mountain and the asymmetry -!! and convexity statistics which are found from running a gravity wave -!! model for a large number of cases: -!! -!! \f$ m^{'} = C_{m} \Delta X \left[ \frac{1 \; + \; -!! \sum\limits_{x} L_{h} }{\Delta X} \right]^{OA+1} \f$ -!! -!! Where, according to Kim, \f$ \sum \frac{L_{h}}{\Delta X} \f$ is -!! the fractional area covered by the subgrid-scale orography higher than -!! a critical height \f$ h_{c} = Fr_{c} U_{0}/N_{0} \f$ , over the -!! "low level" vertically averaged layer, for a grid box with the interval -!! \f$ \Delta X \f$. Each \f$ L_{n}\f$ is the width of a segment of -!! orography intersection at the critical height: -!! -!! \f$ Fr_{0} = \frac{N_{0} \; h^{'}}{U_{0}} \f$ -!! -!! \f$ G^{'}(OC,Fr_{0}) = \frac{Fr_{0}^{2}}{Fr_{0}^{2} \; + \; a^{2}} \f$ -!! -!! \f$ a^{2} = \frac{C_{G}}{OC} \f$ -!! -!! \f$ E(OA, Fr_{0}) = (OA \; + \; 2)^{\delta} \f$ and \f$ \delta -!! \; = \; \frac{C_{E} \; Fr_{0}}{Fr_{c}} \f$ where \f$ Fr_{c} \f$ -!! is as in Alpert. -!! -!! -!! This represents a closed scheme, somewhat empirical adjustments -!! to the original scheme to calculate the surface stress. -!! -!! Momentum is deposited by the sub-grid scale gravity waves break due -!! to the presence of convective mixing assumed to occur when the -!! minimum Richardson number: -!! -!! Orographic Convexity (OC) = \f$ \frac{ \sum\limits_{j=1}^{N_{x}} -!! \; (h_{j} \; - \; \bar{h})^4 }{N_{x} \;\sigma_{h}^4} \f$ , -!! and where \f$ \sigma_{h} = \sqrt{ \frac{\sum\limits_{j=1}^{N_{x}} -!! \; (h_{j} \; - \; \bar{h} )^2}{N_{x}} } \f$ -!! -!! This represents a closed scheme, somewhat empirical adjustments -!! to the original scheme to calculate the surface stress. -!! -!! Momentum is deposited by the sub-grid scale gravity waves break due -!! to the presence of convective mixing assumed to occur when -!! the minimum Richardson number: -!! -!! \f$ Ri_{m} = \frac{Ri(1 \; - \; Fr)}{(1 \; + \; \sqrt{Ri}Fr)^2} \f$ -!! -!! Is less than 1/4 Or if critical layers are encountered in a layer -!! the the momentum flux will vanish. The critical layer is defined -!! when the base layer wind becomes perpendicular to the environmental -!! wind. Otherwise, wave breaking occurs at a level where the amplification -!! of the wave causes the local Froude number or similarly a truncated -!! (first term of the) Scorer parameter, to be reduced below a critical -!! value by the saturation hypothesis (Lindzen,). This is done through -!! eq 1 which can be written as -!! -!! \f$ \tau = \rho U N k h^{'2} \f$ -!! -!! For small Froude number this is discretized in the vertical so at each -!! level the stress is reduced by ratio of the Froude or truncated Scorer -!! parameter, \f$ \frac{U^{2}}{N^{2}} = \frac{N \tau_{l-1}}{\rho U^{3} k} \f$ , -!! where the stress is from the layer below beginning with that found near -!! the surface. The respective change in momentum is applied in -!! that layer building up from below. -!! -!! An amplitude factor is part of the calibration of this scheme which is -!! a function of the model resolution and the vertical diffusion. This -!! is because the vertical diffusion and the GWD account encompass -!! similar physical processes. Thus, one needs to run the model over -!! and over for various amplitude factors for GWD and vertical diffusion. -!! -!! In addition, there is also mountain blocking from lift and frictional -!! forces. Improved integration between how the GWD is calculated and -!! the mountain blocking of wind flow around sub-grid scale orography -!! is underway at NCEP. The GFS already has convectively forced GWD -!! an independent process. The next step is to test -!! -!> \section det_drag_suite GFS Orographic GWD Scheme Detailed Algorithm -!> @{ - subroutine drag_suite_run( & - & IM,KM,dvdt,dudt,dtdt,U1,V1,T1,Q1,KPBL, & - & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,DELTIM,KDT, & - & var,oc1,oa4,ol4, & - & varss,oc1ss,oa4ss,ol4ss, & - & THETA,SIGMA,GAMMA,ELVMAX, & - & dtaux2d_ls,dtauy2d_ls,dtaux2d_bl,dtauy2d_bl, & - & dtaux2d_ss,dtauy2d_ss,dtaux2d_fd,dtauy2d_fd, & - & dusfc,dvsfc, & - & dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & - & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & - & slmsk,br1,hpbl, & - & g, cp, rd, rv, fv, pi, imx, cdmbgwd, me, master, & - & lprnt, ipr, rdxzb, dx, gwd_opt, & - & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & - & dtend, dtidx, index_of_process_orographic_gwd, & - & index_of_temperature, index_of_x_wind, & - & index_of_y_wind, ldiag3d, & - & spp_wts_gwd, spp_gwd, errmsg, errflg) - -! ******************************************************************** -! -----> I M P L E M E N T A T I O N V E R S I O N <---------- -! -! ----- This code ----- -!begin WRF code - -! this code handles the time tendencies of u v due to the effect of mountain -! induced gravity wave drag from sub-grid scale orography. this routine -! not only treats the traditional upper-level wave breaking due to mountain -! variance (alpert 1988), but also the enhanced lower-tropospheric wave -! breaking due to mountain convexity and asymmetry (kim and arakawa 1995). -! thus, in addition to the terrain height data in a model grid box, -! additional 10-2d topographic statistics files are needed, including -! orographic standard deviation (var), convexity (oc1), asymmetry (oa4) -! and ol (ol4). these data sets are prepared based on the 30 sec usgs orography -! hong (1999). the current scheme was implmented as in hong et al.(2008) -! -! Originally coded by song-you hong and young-joon kim and implemented by song-you hong -! -! program history log: -! 2014-10-01 Hyun-Joo Choi (from KIAPS) flow-blocking drag of kim and doyle -! with blocked height by dividing streamline theory -! 2017-04-06 Joseph Olson (from Gert-Jan Steeneveld) added small-scale -! orographic grabity wave drag: -! 2017-09-15 Joseph Olson, with some bug fixes from Michael Toy: added the -! topographic form drag of Beljaars et al. (2004, QJRMS) -! Activation of each component is done by specifying the integer-parameters -! (defined below) to 0: inactive or 1: active -! gwd_opt_ls = 0 or 1: large-scale -! gwd_opt_bl = 0 or 1: blocking drag -! gwd_opt_ss = 0 or 1: small-scale gravity wave drag -! gwd_opt_fd = 0 or 1: topographic form drag -! 2017-09-25 Michael Toy (from NCEP GFS model) added dissipation heating -! gsd_diss_ht_opt = 0: dissipation heating off -! gsd_diss_ht_opt = 1: dissipation heating on -! 2020-08-25 Michael Toy changed logic control for drag component selection -! for CCPP. -! Namelist options: -! do_gsl_drag_ls_bl - logical flag for large-scale GWD + blocking -! do_gsl_drag_ss - logical flag for small-scale GWD -! do_gsl_drag_tofd - logical flag for turbulent form drag -! Compile-time options (same as before): -! gwd_opt_ls = 0 or 1: large-scale GWD -! gwd_opt_bl = 0 or 1: blocking drag -! -! References: -! Hong et al. (2008), wea. and forecasting -! Kim and Doyle (2005), Q. J. R. Meteor. Soc. -! Kim and Arakawa (1995), j. atmos. sci. -! Alpert et al. (1988), NWP conference. -! Hong (1999), NCEP office note 424. -! Steeneveld et al (2008), JAMC -! Tsiringakis et al. (2017), Q. J. R. Meteor. Soc. -! Beljaars et al. (2004), Q. J. R. Meteor. Soc. -! -! notice : comparible or lower resolution orography files than model resolution -! are desirable in preprocess (wps) to prevent weakening of the drag -!------------------------------------------------------------------------------- -! -! input -! dudt (im,km) non-lin tendency for u wind component -! dvdt (im,km) non-lin tendency for v wind component -! u1(im,km) zonal wind / sqrt(rcl) m/sec at t0-dt -! v1(im,km) meridional wind / sqrt(rcl) m/sec at t0-dt -! t1(im,km) temperature deg k at t0-dt -! q1(im,km) specific humidity at t0-dt -! deltim time step secs -! del(km) positive increment of pressure across layer (pa) -! KPBL(IM) is the index of the top layer of the PBL -! ipr & lprnt for diagnostics -! -! output -! dudt, dvdt wind tendency due to gwdo -! dTdt -! -!------------------------------------------------------------------------------- - -!end wrf code -!----------------------------------------------------------------------C -! USE -! ROUTINE IS CALLED FROM CCPP (AFTER CALLING PBL SCHEMES) -! -! PURPOSE -! USING THE GWD PARAMETERIZATIONS OF PS-GLAS AND PH- -! GFDL TECHNIQUE. THE TIME TENDENCIES OF U V -! ARE ALTERED TO INCLUDE THE EFFECT OF MOUNTAIN INDUCED -! GRAVITY WAVE DRAG FROM SUB-GRID SCALE OROGRAPHY INCLUDING -! CONVECTIVE BREAKING, SHEAR BREAKING AND THE PRESENCE OF -! CRITICAL LEVELS -! -! -! ******************************************************************** - USE MACHINE , ONLY : kind_phys - implicit none - - ! Interface variables - integer, intent(in) :: im, km, imx, kdt, ipr, me, master - integer, intent(in) :: gwd_opt - logical, intent(in) :: lprnt - integer, intent(in) :: KPBL(:) - real(kind=kind_phys), intent(in) :: deltim, G, CP, RD, RV, cdmbgwd(:) - real(kind=kind_phys), intent(inout) :: dtend(:,:,:) - logical, intent(in) :: ldiag3d - integer, intent(in) :: dtidx(:,:), index_of_temperature, & - & index_of_process_orographic_gwd, index_of_x_wind, index_of_y_wind - - integer :: kpblmax - integer, parameter :: ims=1, kms=1, its=1, kts=1 - real(kind=kind_phys), intent(in) :: fv, pi - real(kind=kind_phys) :: rcl, cdmb - real(kind=kind_phys) :: g_inv - - real(kind=kind_phys), intent(inout) :: & - & dudt(:,:),dvdt(:,:), & - & dtdt(:,:) - real(kind=kind_phys), intent(out) :: rdxzb(:) - real(kind=kind_phys), intent(in) :: & - & u1(:,:),v1(:,:), & - & t1(:,:),q1(:,:), & - & PHII(:,:),prsl(:,:), & - & prslk(:,:),PHIL(:,:) - real(kind=kind_phys), intent(in) :: prsi(:,:), & - & del(:,:) - real(kind=kind_phys), intent(in) :: var(:),oc1(:), & - & oa4(:,:),ol4(:,:), & - & dx(:) - real(kind=kind_phys), intent(in) :: varss(:),oc1ss(:), & - & oa4ss(:,:),ol4ss(:,:) - real(kind=kind_phys), intent(in) :: THETA(:),SIGMA(:), & - & GAMMA(:),ELVMAX(:) - -! added for small-scale orographic wave drag - real(kind=kind_phys), dimension(im,km) :: utendwave,vtendwave,thx,thvx - real(kind=kind_phys), intent(in) :: br1(:), & - & hpbl(:), & - & slmsk(:) - real(kind=kind_phys), dimension(im) :: govrth,xland - !real(kind=kind_phys), dimension(im,km) :: dz2 - real(kind=kind_phys) :: tauwavex0,tauwavey0, & - & XNBV,density,tvcon,hpbl2 - integer :: kpbl2,kvar - !real(kind=kind_phys), dimension(im,km+1) :: zq ! = PHII/g - real(kind=kind_phys), dimension(im,km) :: zl ! = PHIL/g - -!SPP - real(kind=kind_phys), dimension(im) :: var_stoch, varss_stoch, & - varmax_ss_stoch, varmax_fd_stoch - real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) - integer, intent(in) :: spp_gwd - - real(kind=kind_phys), dimension(im) :: rstoch - -!Output: - real(kind=kind_phys), intent(out) :: & - & dusfc(:), dvsfc(:) -!Output (optional): - real(kind=kind_phys), intent(out) :: & - & dusfc_ls(:),dvsfc_ls(:), & - & dusfc_bl(:),dvsfc_bl(:), & - & dusfc_ss(:),dvsfc_ss(:), & - & dusfc_fd(:),dvsfc_fd(:) - real(kind=kind_phys), intent(out) :: & - & dtaux2d_ls(:,:),dtauy2d_ls(:,:), & - & dtaux2d_bl(:,:),dtauy2d_bl(:,:), & - & dtaux2d_ss(:,:),dtauy2d_ss(:,:), & - & dtaux2d_fd(:,:),dtauy2d_fd(:,:) - -!Misc arrays - real(kind=kind_phys), dimension(im,km) :: dtaux2d, dtauy2d - -!------------------------------------------------------------------------- -! Flags to regulate the activation of specific components of drag suite: -! Each component is tapered off automatically as a function of dx, so best to -! keep them activated (.true.). - logical, intent(in) :: & - do_gsl_drag_ls_bl, & ! large-scale gravity wave drag and blocking - do_gsl_drag_ss, & ! small-scale gravity wave drag (Steeneveld et al. 2008) - do_gsl_drag_tofd ! form drag (Beljaars et al. 2004, QJRMS) - -! Additional flags - integer, parameter :: & - gwd_opt_ls = 1, & ! large-scale gravity wave drag - gwd_opt_bl = 1, & ! blocking drag - gsd_diss_ht_opt = 0 - -! Parameters for bounding the scale-adaptive variability: -! Small-scale GWD + turbulent form drag - real(kind=kind_phys), parameter :: dxmin_ss = 1000., & - & dxmax_ss = 12000. ! min,max range of tapering (m) -! Large-scale GWD + blocking - real(kind=kind_phys), parameter :: dxmin_ls = 3000., & - & dxmax_ls = 13000. ! min,max range of tapering (m) - real(kind=kind_phys), dimension(im) :: ss_taper, ls_taper ! small- and large-scale tapering factors (-) -! -! Variables for limiting topographic standard deviation (var) - real(kind=kind_phys), parameter :: varmax_ss = 50., & - varmax_fd = 150., & - beta_ss = 0.1, & - beta_fd = 0.2 - real(kind=kind_phys) :: var_temp, var_temp2 - -! added Beljaars orographic form drag - real(kind=kind_phys), dimension(im,km) :: utendform,vtendform - real(kind=kind_phys) :: a1,a2,wsp - real(kind=kind_phys) :: H_efold - -! critical richardson number for wave breaking : ! larger drag with larger value - real(kind=kind_phys), parameter :: ric = 0.25 - real(kind=kind_phys), parameter :: dw2min = 1. - real(kind=kind_phys), parameter :: rimin = -100. - real(kind=kind_phys), parameter :: bnv2min = 1.0e-5 - real(kind=kind_phys), parameter :: efmin = 0.0 - real(kind=kind_phys), parameter :: efmax = 10.0 - real(kind=kind_phys), parameter :: xl = 4.0e4 - real(kind=kind_phys), parameter :: critac = 1.0e-5 - real(kind=kind_phys), parameter :: gmax = 1. - real(kind=kind_phys), parameter :: veleps = 1.0 - real(kind=kind_phys), parameter :: factop = 0.5 - real(kind=kind_phys), parameter :: frc = 1.0 - real(kind=kind_phys), parameter :: ce = 0.8 - real(kind=kind_phys), parameter :: cg = 0.5 - integer,parameter :: kpblmin = 2 - -! -! local variables -! - integer :: i,j,k,lcap,lcapp1,nwd,idir, & - klcap,kp1 -! - real(kind=kind_phys) :: rcs,csg,fdir,cleff,cleff_ss,cs, & - rcsks,wdir,ti,rdz,tem2,dw2,shr2, & - bvf2,rdelks,wtkbj,tem,gfobnv,hd,fro, & - rim,temc,tem1,efact,temv,dtaux,dtauy, & - dtauxb,dtauyb,eng0,eng1 -! - logical :: ldrag(im),icrilv(im), & - flag(im),kloop1(im) -! - real(kind=kind_phys) :: taub(im),taup(im,km+1), & - xn(im),yn(im), & - ubar(im),vbar(im), & - fr(im),ulow(im), & - rulow(im),bnv(im), & - oa(im),ol(im), & - oass(im),olss(im), & - roll(im),dtfac(im), & - brvf(im),xlinv(im), & - delks(im),delks1(im), & - bnv2(im,km),usqj(im,km), & - taud_ls(im,km),taud_bl(im,km), & - ro(im,km), & - vtk(im,km),vtj(im,km), & - zlowtop(im),velco(im,km-1), & - coefm(im),coefm_ss(im) -! - integer :: kbl(im),klowtop(im) - integer,parameter :: mdir=8 - !integer :: nwdir(mdir) - !data nwdir/6,7,5,8,2,3,1,4/ - integer, parameter :: nwdir(8) = (/6,7,5,8,2,3,1,4/) -! -! variables for flow-blocking drag -! - real(kind=kind_phys),parameter :: frmax = 10. - real(kind=kind_phys),parameter :: olmin = 1.0e-5 - real(kind=kind_phys),parameter :: odmin = 0.1 - real(kind=kind_phys),parameter :: odmax = 10. - real(kind=kind_phys),parameter :: erad = 6371.315e+3 - integer :: komax(im) - integer :: kblk - real(kind=kind_phys) :: cd - real(kind=kind_phys) :: zblk,tautem - real(kind=kind_phys) :: pe,ke - real(kind=kind_phys) :: delx,dely - real(kind=kind_phys) :: dxy4(im,4),dxy4p(im,4) - real(kind=kind_phys) :: dxy(im),dxyp(im) - real(kind=kind_phys) :: ol4p(4),olp(im),od(im) - real(kind=kind_phys) :: taufb(im,km+1) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: udtend, vdtend, Tdtend - - ! Calculate inverse of gravitational acceleration - g_inv = 1./G - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Initialize local variables - var_temp2 = 0. - udtend = -1 - vdtend = -1 - Tdtend = -1 - - if(ldiag3d) then - udtend = dtidx(index_of_x_wind,index_of_process_orographic_gwd) - vdtend = dtidx(index_of_y_wind,index_of_process_orographic_gwd) - Tdtend = dtidx(index_of_temperature,index_of_process_orographic_gwd) - endif - -!-------------------------------------------------------------------- -! SCALE-ADPTIVE PARAMETER FROM GFS GWD SCHEME -!-------------------------------------------------------------------- -! parameter (cdmb = 1.0) ! non-dim sub grid mtn drag Amp (*j*) -! 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) - if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) - -!>-# Orographic Gravity Wave Drag Section - kpblmax = km / 2 ! maximum pbl height : # of vertical levels / 2 -! -! Scale cleff between IM=384*2 and 192*2 for T126/T170 and T62 -! - if (imx > 0) then -! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/384.0) -! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! -! cleff = 0.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! -! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192)/float(IMX/192) -! cleff = 1.0E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! - cleff = 0.5E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! -! hmhj for ndsl -! jw cleff = 0.1E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! -! cleff = 2.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! -! cleff = 2.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! - endif - if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) -!-------------------------------------------------------------------- -! END SCALE-ADPTIVE PARAMETER SECTION -!-------------------------------------------------------------------- -! -!---- constants -! - rcl = 1. - rcs = sqrt(rcl) - cs = 1. / sqrt(rcl) - csg = cs * g - lcap = km - lcapp1 = lcap + 1 - fdir = mdir / (2.0*pi) - - do i=1,im - if (slmsk(i)==1. .or. slmsk(i)==2.) then !sea/land/ice mask (=0/1/2) in FV3 - xland(i)=1.0 !but land/water = (1/2) in this module - else - xland(i)=2.0 - endif - RDXZB(i) = 0.0 - enddo - -!--- calculate scale-aware tapering factors -do i=1,im - if ( dx(i) .ge. dxmax_ls ) then - ls_taper(i) = 1. - else - if ( dx(i) .le. dxmin_ls) then - ls_taper(i) = 0. - else - ls_taper(i) = 0.5 * ( SIN(pi*(dx(i)-0.5*(dxmax_ls+dxmin_ls))/ & - (dxmax_ls-dxmin_ls)) + 1. ) - endif - 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 - -! SPP, if spp_gwd is 0, no perturbations are applied. -if ( spp_gwd==1 ) then - do i = its,im - var_stoch(i) = var(i) + var(i)*0.75*spp_wts_gwd(i,1) - varss_stoch(i) = varss(i) + varss(i)*0.75*spp_wts_gwd(i,1) - varmax_ss_stoch(i) = varmax_ss + varmax_ss*0.75*spp_wts_gwd(i,1) - varmax_fd_stoch(i) = varmax_fd + varmax_fd*0.75*spp_wts_gwd(i,1) - enddo -else - do i = its,im - var_stoch(i) = var(i) - varss_stoch(i) = varss(i) - varmax_ss_stoch(i) = varmax_ss - varmax_fd_stoch(i) = varmax_fd - enddo -endif - -!--- calculate length of grid for flow-blocking drag -! -do i=1,im - delx = dx(i) - dely = dx(i) - dxy4(i,1) = delx - dxy4(i,2) = dely - dxy4(i,3) = sqrt(delx*delx + dely*dely) - dxy4(i,4) = dxy4(i,3) - dxy4p(i,1) = dxy4(i,2) - dxy4p(i,2) = dxy4(i,1) - dxy4p(i,3) = dxy4(i,4) - dxy4p(i,4) = dxy4(i,3) -enddo -! -!-----initialize arrays -! - dtaux = 0.0 - dtauy = 0.0 - do i = its,im - klowtop(i) = 0 - kbl(i) = 0 - enddo -! - do i = its,im - xn(i) = 0.0 - yn(i) = 0.0 - ubar (i) = 0.0 - vbar (i) = 0.0 - roll (i) = 0.0 - taub (i) = 0.0 - oa(i) = 0.0 - ol(i) = 0.0 - oass(i) = 0.0 - olss(i) = 0.0 - ulow (i) = 0.0 - dtfac(i) = 1.0 - rstoch(i) = 0.0 - ldrag(i) = .false. - icrilv(i) = .false. - flag(i) = .true. - enddo - - do k = kts,km - do i = its,im - usqj(i,k) = 0.0 - bnv2(i,k) = 0.0 - vtj(i,k) = 0.0 - vtk(i,k) = 0.0 - taup(i,k) = 0.0 - taud_ls(i,k) = 0.0 - taud_bl(i,k) = 0.0 - dtaux2d(i,k) = 0.0 - dtauy2d(i,k) = 0.0 - enddo - enddo -! - if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then - do i = its,im - dusfc_ls(i) = 0.0 - dvsfc_ls(i) = 0.0 - dusfc_bl(i) = 0.0 - dvsfc_bl(i) = 0.0 - dusfc_ss(i) = 0.0 - dvsfc_ss(i) = 0.0 - dusfc_fd(i) = 0.0 - dvsfc_fd(i) = 0.0 - enddo - do k = kts,km - do i = its,im - dtaux2d_ls(i,k)= 0.0 - dtauy2d_ls(i,k)= 0.0 - dtaux2d_bl(i,k)= 0.0 - dtauy2d_bl(i,k)= 0.0 - dtaux2d_ss(i,k)= 0.0 - dtauy2d_ss(i,k)= 0.0 - dtaux2d_fd(i,k)= 0.0 - dtauy2d_fd(i,k)= 0.0 - enddo - enddo - endif - - do i = its,im - taup(i,km+1) = 0.0 - xlinv(i) = 1.0/xl - dusfc(i) = 0.0 - dvsfc(i) = 0.0 - enddo -! -! initialize array for flow-blocking drag -! - taufb(1:im,1:km+1) = 0.0 - komax(1:im) = 0 -! - do k = kts,km - do i = its,im - vtj(i,k) = t1(i,k) * (1.+fv*q1(i,k)) - vtk(i,k) = vtj(i,k) / prslk(i,k) - ro(i,k) = 1./rd * prsl(i,k) / vtj(i,k) ! density kg/m**3 - enddo - enddo -! -! calculate mid-layer height (zl), interface height (zq), and layer depth (dz2). -! - !zq=0. - do k = kts,km - do i = its,im - !zq(i,k+1) = PHII(i,k+1)*g_inv - !dz2(i,k) = (PHII(i,k+1)-PHII(i,k))*g_inv - zl(i,k) = PHIL(i,k)*g_inv - enddo - enddo -! -! determine reference level: maximum of 2*var and pbl heights -! - do i = its,im - zlowtop(i) = 2. * var_stoch(i) - enddo -! - do i = its,im - kloop1(i) = .true. - enddo -! - do k = kts+1,km - do i = its,im - if(kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then - klowtop(i) = k+1 - kloop1(i) = .false. - endif - enddo - enddo -! - do i = its,im - kbl(i) = max(kpbl(i), klowtop(i)) - kbl(i) = max(min(kbl(i),kpblmax),kpblmin) - enddo -! -! determine the level of maximum orographic height -! - ! komax(:) = kbl(:) - komax(:) = klowtop(:) - 1 ! modification by NOAA/GSD March 2018 -! - do i = its,im - delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) - delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) - enddo -! -! compute low level averages within pbl -! - do k = kts,kpblmax - do i = its,im - if (k.lt.kbl(i)) then - rcsks = rcs * del(i,k) * delks(i) - rdelks = del(i,k) * delks(i) - ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean - vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean - roll(i) = roll(i) + rdelks * ro(i,k) ! ro mean - endif - enddo - enddo -! -! figure out low-level horizontal wind direction -! -! nwd 1 2 3 4 5 6 7 8 -! wd w s sw nw e n ne se -! - do i = its,im - wdir = atan2(ubar(i),vbar(i)) + pi - idir = mod(nint(fdir*wdir),mdir) + 1 - nwd = nwdir(idir) - oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) - ol(i) = ol4(i,mod(nwd-1,4)+1) - ! Repeat for small-scale gwd - oass(i) = (1-2*int( (nwd-1)/4 )) * oa4ss(i,mod(nwd-1,4)+1) - olss(i) = ol4ss(i,mod(nwd-1,4)+1) - -! -!----- compute orographic width along (ol) and perpendicular (olp) -!----- the direction of wind -! - ol4p(1) = ol4(i,2) - ol4p(2) = ol4(i,1) - ol4p(3) = ol4(i,4) - ol4p(4) = ol4(i,3) - olp(i) = ol4p(mod(nwd-1,4)+1) -! -!----- compute orographic direction (horizontal orographic aspect ratio) -! - od(i) = olp(i)/max(ol(i),olmin) - od(i) = min(od(i),odmax) - od(i) = max(od(i),odmin) -! -!----- compute length of grid in the along(dxy) and cross(dxyp) wind directions -! - dxy(i) = dxy4(i,MOD(nwd-1,4)+1) - dxyp(i) = dxy4p(i,MOD(nwd-1,4)+1) - enddo -! -! END INITIALIZATION; BEGIN GWD CALCULATIONS: -! -IF ( (do_gsl_drag_ls_bl).and. & - ((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)) ) then - - do i=its,im - - if ( ls_taper(i).GT.1.E-02 ) then - -! -!--- saving richardson number in usqj for migwdi -! - do k = kts,km-1 - ti = 2.0 / (t1(i,k)+t1(i,k+1)) - rdz = 1./(zl(i,k+1) - zl(i,k)) - tem1 = u1(i,k) - u1(i,k+1) - tem2 = v1(i,k) - v1(i,k+1) - dw2 = rcl*(tem1*tem1 + tem2*tem2) - shr2 = max(dw2,dw2min) * rdz * rdz - bvf2 = g*(g/cp+rdz*(vtj(i,k+1)-vtj(i,k))) * ti - usqj(i,k) = max(bvf2/shr2,rimin) - bnv2(i,k) = 2.0*g*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) - bnv2(i,k) = max( bnv2(i,k), bnv2min ) - enddo -! -!----compute the "low level" or 1/3 wind magnitude (m/s) -! - ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) - rulow(i) = 1./ulow(i) -! - do k = kts,km-1 - velco(i,k) = (0.5*rcs) * ((u1(i,k)+u1(i,k+1)) * ubar(i) & - + (v1(i,k)+v1(i,k+1)) * vbar(i)) - velco(i,k) = velco(i,k) * rulow(i) - if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then - velco(i,k) = veleps - endif - enddo -! -! no drag when critical level in the base layer -! - ldrag(i) = velco(i,1).le.0. -! -! no drag when velco.lt.0 -! - do k = kpblmin,kpblmax - if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0. - enddo -! -! no drag when bnv2.lt.0 -! - do k = kts,kpblmax - if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. bnv2(i,k).lt.0. - enddo -! -!-----the low level weighted average ri is stored in usqj(1,1; im) -!-----the low level weighted average n**2 is stored in bnv2(1,1; im) -!---- this is called bnvl2 in phys_gwd_alpert_sub not bnv2 -!---- rdelks (del(k)/delks) vert ave factor so we can * instead of / -! - wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) - bnv2(i,1) = wtkbj * bnv2(i,1) - usqj(i,1) = wtkbj * usqj(i,1) -! - do k = kpblmin,kpblmax - if (k .lt. kbl(i)) then - rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) - bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks - usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks - endif - enddo -! - ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 - ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 - ldrag(i) = ldrag(i) .or. var_stoch(i) .le. 0.0 -! -! set all ri low level values to the low level value -! - do k = kpblmin,kpblmax - if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) - enddo -! - if (.not.ldrag(i)) then - bnv(i) = sqrt( bnv2(i,1) ) - fr(i) = bnv(i) * rulow(i) * 2. * var_stoch(i) * od(i) - fr(i) = min(fr(i),frmax) - xn(i) = ubar(i) * rulow(i) - yn(i) = vbar(i) * rulow(i) - endif -! -! compute the base level stress and store it in taub -! calculate enhancement factor, number of mountains & aspect -! ratio const. use simplified relationship between standard -! deviation & critical hgt - - if (.not. ldrag(i)) then - efact = (oa(i) + 2.) ** (ce*fr(i)/frc) - efact = min( max(efact,efmin), efmax ) -!!!!!!! cleff (effective grid length) is highly tunable parameter -!!!!!!! the bigger (smaller) value produce weaker (stronger) wave drag -!WRF cleff = sqrt(dxy(i)**2. + dxyp(i)**2.) -!WRF cleff = 3. * max(dx(i),cleff) - coefm(i) = (1. + ol(i)) ** (oa(i)+1.) -!WRF xlinv(i) = coefm(i) / cleff - xlinv(i) = coefm(i) * cleff - tem = fr(i) * fr(i) * oc1(i) - gfobnv = gmax * tem / ((tem + cg)*bnv(i)) - if ( gwd_opt_ls .NE. 0 ) then - taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & - * ulow(i) * gfobnv * efact - else ! We've gotten what we need for the blocking scheme - taub(i) = 0.0 - end if - else - taub(i) = 0.0 - xn(i) = 0.0 - yn(i) = 0.0 - endif - - endif ! (ls_taper(i).GT.1.E-02) - - enddo ! do i=its,im - -ENDIF ! (do_gsl_drag_ls_bl).and.((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)) - -!========================================================= -! add small-scale wavedrag for stable boundary layer -!========================================================= - XNBV=0. - tauwavex0=0. - tauwavey0=0. - density=1.2 - utendwave=0. - vtendwave=0. -! -IF ( do_gsl_drag_ss ) THEN - - do i=its,im - - if ( ss_taper(i).GT.1.E-02 ) then - ! - ! calculating potential temperature - ! - do k = kts,km - thx(i,k) = t1(i,k)/prslk(i,k) - enddo - ! - do k = kts,km - tvcon = (1.+fv*q1(i,k)) - thvx(i,k) = thx(i,k)*tvcon - enddo - - hpbl2 = hpbl(i)+10. - kpbl2 = kpbl(i) - !kvar = MIN(kpbl, k-level of var) - kvar = 1 - do k=kts+1,MAX(kpbl(i),kts+1) -! IF (zl(i,k)>2.*var(i) .or. zl(i,k)>2*varmax) then - IF (zl(i,k)>300.) then - kpbl2 = k - IF (k == kpbl(i)) then - hpbl2 = hpbl(i)+10. - ELSE - hpbl2 = zl(i,k)+10. - ENDIF - exit - ENDIF - 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 -! 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 - !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)) - XNBV=sqrt(govrth(i)*(thvx(i,kpbl2)-thvx(i,kts))/hpbl2) -! - !if(abs(XNBV/u1(i,kpbl(i))).gt.xlinv(i))then - if(abs(XNBV/u1(i,kpbl2)).gt.xlinv(i))then - !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))) - ! 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) - tauwavex0=tauwavex0*ss_taper(i) - else - tauwavex0=0. - endif -! - !if(abs(XNBV/v1(i,kpbl(i))).gt.xlinv(i))then - if(abs(XNBV/v1(i,kpbl2)).gt.xlinv(i))then - !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))) - ! 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) - tauwavey0=tauwavey0*ss_taper(i) - else - tauwavey0=0. - endif - - do k=kts,kpbl(i) !MIN(kpbl2+1,km-1) -!original - !utendwave(i,k)=-1.*tauwavex0*2.*max((1.-zl(i,k)/hpbl(i)),0.)/hpbl(i) - !vtendwave(i,k)=-1.*tauwavey0*2.*max((1.-zl(i,k)/hpbl(i)),0.)/hpbl(i) -!new - utendwave(i,k)=-1.*tauwavex0*2.*max((1.-zl(i,k)/hpbl2),0.)/hpbl2 - vtendwave(i,k)=-1.*tauwavey0*2.*max((1.-zl(i,k)/hpbl2),0.)/hpbl2 -!mod-to be used in HRRRv3/RAPv4 - !utendwave(i,k)=-1.*tauwavex0 * max((1.-zl(i,k)/hpbl2),0.)**2 - !vtendwave(i,k)=-1.*tauwavey0 * max((1.-zl(i,k)/hpbl2),0.)**2 - enddo - endif - endif - - do k = kts,km - dudt(i,k) = dudt(i,k) + utendwave(i,k) - dvdt(i,k) = dvdt(i,k) + vtendwave(i,k) - dusfc(i) = dusfc(i) + utendwave(i,k) * del(i,k) - dvsfc(i) = dvsfc(i) + vtendwave(i,k) * del(i,k) - enddo - if(udtend>0) then - dtend(i,kts:km,udtend) = dtend(i,kts:km,udtend) + utendwave(i,kts:km)*deltim - endif - if(vdtend>0) then - dtend(i,kts:km,vdtend) = dtend(i,kts:km,vdtend) + vtendwave(i,kts:km)*deltim - endif - if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then - do k = kts,km - dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) - dvsfc_ss(i) = dvsfc_ss(i) + vtendwave(i,k) * del(i,k) - dtaux2d_ss(i,k) = utendwave(i,k) - dtauy2d_ss(i,k) = vtendwave(i,k) - enddo - endif - - endif ! if (ss_taper(i).GT.1.E-02) - - enddo ! i=its,im - -ENDIF ! if (do_gsl_drag_ss) - -!================================================================ -! Topographic Form Drag from Beljaars et al. (2004, QJRMS, equ. 16): -!================================================================ -IF ( do_gsl_drag_tofd ) THEN - - do i=its,im - - if ( ss_taper(i).GT.1.E-02 ) then - - utendform=0. - vtendform=0. - - 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.) - 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.) - 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 - var_temp = 0.0759*EXP(-(zl(i,k)/H_efold)**1.5)*a2* & - zl(i,k)**(-1.2)*ss_taper(i) ! this is greater than zero - ! Note: This is a semi-implicit treatment of the time differencing - ! per Beljaars et al. (2004, QJRMS) - utendform(i,k) = - var_temp*wsp*u1(i,k)/(1. + var_temp*deltim*wsp) - vtendform(i,k) = - var_temp*wsp*v1(i,k)/(1. + var_temp*deltim*wsp) - !IF(zl(i,k) > 4000.) exit - ENDDO - ENDIF - - do k = kts,km - dudt(i,k) = dudt(i,k) + utendform(i,k) - dvdt(i,k) = dvdt(i,k) + vtendform(i,k) - dusfc(i) = dusfc(i) + utendform(i,k) * del(i,k) - dvsfc(i) = dvsfc(i) + vtendform(i,k) * del(i,k) - enddo - if(udtend>0) then - dtend(i,kts:km,udtend) = dtend(i,kts:km,udtend) + utendform(i,kts:km)*deltim - endif - if(vdtend>0) then - dtend(i,kts:km,vdtend) = dtend(i,kts:km,vdtend) + vtendform(i,kts:km)*deltim - endif - if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then - do k = kts,km - dtaux2d_fd(i,k) = utendform(i,k) - dtauy2d_fd(i,k) = vtendform(i,k) - dusfc_fd(i) = dusfc_fd(i) + utendform(i,k) * del(i,k) - dvsfc_fd(i) = dvsfc_fd(i) + vtendform(i,k) * del(i,k) - enddo - endif - - endif ! if (ss_taper(i).GT.1.E-02) - - enddo ! i=its,im - -ENDIF ! if (do_gsl_drag_tofd) -!======================================================= -! More for the large-scale gwd component -IF ( (do_gsl_drag_ls_bl).and.(gwd_opt_ls .EQ. 1) ) THEN - - do i=its,im - - if ( ls_taper(i).GT.1.E-02 ) then - -! -! now compute vertical structure of the stress. - do k = kts,kpblmax - if (k .le. kbl(i)) taup(i,k) = taub(i) - enddo -! - do k = kpblmin, km-1 ! vertical level k loop! - kp1 = k + 1 -! -! unstablelayer if ri < ric -! unstable layer if upper air vel comp along surf vel <=0 (crit lay) -! at (u-c)=0. crit layer exists and bit vector should be set (.le.) -! - if (k .ge. kbl(i)) then - icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & - .or. (velco(i,k) .le. 0.0) - brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared - brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency - endif -! - if (k .ge. kbl(i) .and. (.not. ldrag(i))) then - if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then - temv = 1.0 / velco(i,k) - tem1 = coefm(i)/dxy(i)*(ro(i,kp1)+ro(i,k))*brvf(i)* & - velco(i,k)*0.5 - hd = sqrt(taup(i,k) / tem1) - fro = brvf(i) * hd * temv -! -! rim is the minimum-richardson number by shutts (1985) - tem2 = sqrt(usqj(i,k)) - tem = 1. + tem2 * fro - rim = usqj(i,k) * (1.-fro) / (tem * tem) -! -! check stability to employ the 'saturation hypothesis' -! of lindzen (1981) except at tropospheric downstream regions -! - if (rim .le. ric) then ! saturation hypothesis! - if ((oa(i) .le. 0.).or.(kp1 .ge. kpblmin )) then - temc = 2.0 + 1.0 / tem2 - hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) - taup(i,kp1) = tem1 * hd * hd - endif - else ! no wavebreaking! - taup(i,kp1) = taup(i,k) - endif - endif - endif - enddo -! - if(lcap.lt.km) then - do klcap = lcapp1,km - taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) - enddo - endif - - endif ! if ( ls_taper(i).GT.1.E-02 ) - - enddo ! do i=its,im - -ENDIF ! (do_gsl_drag_ls_bl).and.(gwd_opt_ls .EQ. 1) -!=============================================================== -!COMPUTE BLOCKING COMPONENT -!=============================================================== -IF ( (do_gsl_drag_ls_bl) .and. (gwd_opt_bl .EQ. 1) ) THEN - - do i=its,im - - if ( ls_taper(i).GT.1.E-02 ) then - - if (.not.ldrag(i)) then -! -!------- determine the height of flow-blocking layer -! - kblk = 0 - pe = 0.0 - do k = km, kpblmin, -1 - if(kblk.eq.0 .and. k.le.komax(i)) then - pe = pe + bnv2(i,k)*(zl(i,komax(i))-zl(i,k))* & - del(i,k)/g/ro(i,k) - ke = 0.5*((rcs*u1(i,k))**2.+(rcs*v1(i,k))**2.) -! -!---------- apply flow-blocking drag when pe >= ke -! - if(pe.ge.ke) then - kblk = k - kblk = min(kblk,kbl(i)) - zblk = zl(i,kblk)-zl(i,kts) - RDXZB(i) = real(k,kind=kind_phys) - endif - endif - enddo - if(kblk.ne.0) then -! -!--------- compute flow-blocking stress -! - cd = max(2.0-1.0/od(i),0.0) - taufb(i,kts) = 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) - do k = kts+1, kblk - taufb(i,k) = taufb(i,k-1) - tautem - enddo -! -!----------sum orographic GW stress and flow-blocking stress -! - ! taup(i,:) = taup(i,:) + taufb(i,:) ! Keep taup and taufb separate for now - endif - - endif ! if (.not.ldrag(i)) - - endif ! if ( ls_taper(i).GT.1.E-02 ) - - enddo ! do i=its,im - -ENDIF ! IF ( (do_gsl_drag_ls_bl) .and. (gwd_opt_bl .EQ. 1) ) -!=========================================================== -IF ( (do_gsl_drag_ls_bl) .and. & - (gwd_opt_ls .EQ. 1 .OR. gwd_opt_bl .EQ. 1) ) THEN - - do i=its,im - - if ( ls_taper(i) .GT. 1.E-02 ) then - -! -! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy -! - do k = kts,km - taud_ls(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) - taud_bl(i,k) = 1. * (taufb(i,k+1) - taufb(i,k)) * csg / del(i,k) - enddo -! -! limit de-acceleration (momentum deposition ) at top to 1/2 value -! the idea is some stuff must go out the 'top' - do klcap = lcap,km - taud_ls(i,klcap) = taud_ls(i,klcap) * factop - taud_bl(i,klcap) = taud_bl(i,klcap) * factop - enddo -! -! if the gravity wave drag would force a critical line -! in the lower ksmm1 layers during the next deltim timestep, -! then only apply drag until that critical line is reached. -! - do k = kts,kpblmax-1 - if (k .le. kbl(i)) then - if ((taud_ls(i,k)+taud_bl(i,k)).ne.0.) & - dtfac(i) = min(dtfac(i),abs(velco(i,k) & - /(deltim*rcs*(taud_ls(i,k)+taud_bl(i,k))))) - endif - enddo -! - do k = kts,km - taud_ls(i,k) = taud_ls(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i)) - taud_bl(i,k) = taud_bl(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i)) - - dtaux = taud_ls(i,k) * xn(i) - dtauy = taud_ls(i,k) * yn(i) - dtauxb = taud_bl(i,k) * xn(i) - dtauyb = taud_bl(i,k) * yn(i) - - !add blocking and large-scale contributions to tendencies - dudt(i,k) = dtaux + dtauxb + dudt(i,k) - dvdt(i,k) = dtauy + dtauyb + dvdt(i,k) - - if ( gsd_diss_ht_opt .EQ. 1 ) then - ! Calculate dissipation heating - ! Initial kinetic energy (at t0-dt) - eng0 = 0.5*( (rcs*u1(i,k))**2. + (rcs*v1(i,k))**2. ) - ! Kinetic energy after wave-breaking/flow-blocking - eng1 = 0.5*( (rcs*(u1(i,k)+(dtaux+dtauxb)*deltim))**2 + & - (rcs*(v1(i,k)+(dtauy+dtauyb)*deltim))**2 ) - ! Modify theta tendency - dtdt(i,k) = dtdt(i,k) + max((eng0-eng1),0.0)/cp/deltim - if ( Tdtend>0 ) then - dtend(i,k,Tdtend) = dtend(i,k,Tdtend) + max((eng0-eng1),0.0)/cp - endif - endif - - dusfc(i) = dusfc(i) + taud_ls(i,k)*xn(i)*del(i,k) + & - taud_bl(i,k)*xn(i)*del(i,k) - dvsfc(i) = dvsfc(i) + taud_ls(i,k)*yn(i)*del(i,k) + & - taud_bl(i,k)*yn(i)*del(i,k) - if(udtend>0) then - dtend(i,k,udtend) = dtend(i,k,udtend) + (taud_ls(i,k) * & - xn(i) + taud_bl(i,k) * xn(i)) * deltim - endif - if(vdtend>0) then - dtend(i,k,vdtend) = dtend(i,k,vdtend) + (taud_ls(i,k) * & - yn(i) + taud_bl(i,k) * yn(i)) * deltim - endif - - enddo - - ! Finalize dusfc and dvsfc diagnostics - dusfc(i) = (-1./g*rcs) * dusfc(i) - dvsfc(i) = (-1./g*rcs) * dvsfc(i) - - if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then - do k = kts,km - dtaux2d_ls(i,k) = taud_ls(i,k) * xn(i) - dtauy2d_ls(i,k) = taud_ls(i,k) * yn(i) - dtaux2d_bl(i,k) = taud_bl(i,k) * xn(i) - dtauy2d_bl(i,k) = taud_bl(i,k) * yn(i) - dusfc_ls(i) = dusfc_ls(i) + dtaux2d_ls(i,k) * del(i,k) - dvsfc_ls(i) = dvsfc_ls(i) + dtauy2d_ls(i,k) * del(i,k) - dusfc_bl(i) = dusfc_bl(i) + dtaux2d_bl(i,k) * del(i,k) - dvsfc_bl(i) = dvsfc_bl(i) + dtauy2d_bl(i,k) * del(i,k) - enddo - endif - - endif ! if ( ls_taper(i) .GT. 1.E-02 ) - - enddo ! do i=its,im - -ENDIF ! (do_gsl_drag_ls_bl).and.(gwd_opt_ls.EQ.1 .OR. gwd_opt_bl.EQ.1) - -if ( (gwd_opt == 33).or.(gwd_opt == 22) ) then - ! Finalize dusfc and dvsfc diagnostics - do i = its,im - dusfc_ls(i) = (-1./g*rcs) * dusfc_ls(i) - dvsfc_ls(i) = (-1./g*rcs) * dvsfc_ls(i) - dusfc_bl(i) = (-1./g*rcs) * dusfc_bl(i) - dvsfc_bl(i) = (-1./g*rcs) * dvsfc_bl(i) - dusfc_ss(i) = (-1./g*rcs) * dusfc_ss(i) - dvsfc_ss(i) = (-1./g*rcs) * dvsfc_ss(i) - dusfc_fd(i) = (-1./g*rcs) * dusfc_fd(i) - dvsfc_fd(i) = (-1./g*rcs) * dvsfc_fd(i) - enddo -endif -! - return - end subroutine drag_suite_run -!------------------------------------------------------------------- -! - subroutine drag_suite_finalize() - end subroutine drag_suite_finalize - - end module drag_suite From 10fa17e895ecd21db0d24d1cef7b12523cabce40 Mon Sep 17 00:00:00 2001 From: wx20hw Date: Wed, 16 Feb 2022 20:03:11 +0000 Subject: [PATCH 117/212] 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 def0e78c4c6e94ea32e9f526e1408ae31e2467db Mon Sep 17 00:00:00 2001 From: jeff beck Date: Thu, 17 Feb 2022 20:10:50 +0000 Subject: [PATCH 118/212] Update spp_mp to equal 7 in if statement. --- physics/mp_thompson.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 01874db40..7c76ea933 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -495,7 +495,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & end if ! Set stochastic physics selection to apply all perturbations - if ( spp_mp ) then + if ( spp_mp==7 ) then spp_mp_opt=7 else spp_mp_opt=0 From 372febe9ab1c26a0116fba27b2d85f70ec165ab5 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 21 Feb 2022 11:39:15 -0700 Subject: [PATCH 119/212] edit module_mp_thompson.F90 to remove optional keyword for rand_pert (AKA spp_wts_mp); change to assumed-shape and reduce rank to match rank of input (i,k) instead of (i,j,k) --- physics/module_mp_thompson.F90 | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 9a25f0315..c23b6d1d8 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1026,7 +1026,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):: & re_cloud, re_ice, re_snow INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch - REAL, DIMENSION(ims:ime,kms:kme_stoch,jms:jme), INTENT(IN), OPTIONAL:: & + REAL, DIMENSION(:,:), INTENT(IN) :: & rand_pert INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs @@ -1123,12 +1123,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! No need to test for every subcycling step test_only_once: if (first_time_step .and. istep==1) then ! Activate this code when removing the guard above - if (rand_perturb_on .ne. 0 .and. .not. present(rand_pert)) then - errmsg = 'Logic error in mp_gt_driver: random perturbations are on, ' // & - 'but optional argument rand_pert is not present' - errflg = 1 - return - end if if ( (present(tt) .and. (present(th) .or. present(pii))) .or. & (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then @@ -1294,11 +1288,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rand2 = 0.0 rand3 = 0.0 if (rand_perturb_on .ne. 0) then - if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1,j) + if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1) m = RSHIFT(ABS(rand_perturb_on),1) - if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,1,j)*2. + 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,j)+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 eef1e235a14cf41ddd0a34c388b1eb9da795d605 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Mon, 21 Feb 2022 19:10:23 +0000 Subject: [PATCH 120/212] Loop over i,j instead of i,1 for rand_pert field. --- physics/module_mp_thompson.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index c23b6d1d8..2478f828c 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1288,11 +1288,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rand2 = 0.0 rand3 = 0.0 if (rand_perturb_on .ne. 0) then - if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1) + if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,j) m = RSHIFT(ABS(rand_perturb_on),1) - if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,1)*2. + if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,j)*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,j)+ABS(min_rand)) m = RSHIFT(ABS(rand_perturb_on),3) endif !+---+-----------------------------------------------------------------+ From ac7cde77cc1a983b500570864e4b12db8364e325 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Mon, 21 Feb 2022 19:23:11 +0000 Subject: [PATCH 121/212] Revert dimensions changes to rand_pert. --- physics/module_mp_thompson.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 2478f828c..c23b6d1d8 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1288,11 +1288,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rand2 = 0.0 rand3 = 0.0 if (rand_perturb_on .ne. 0) then - if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,j) + if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1) m = RSHIFT(ABS(rand_perturb_on),1) - if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,j)*2. + 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,j)+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 14ca01effa097f0932f6132b66defa5b63eab5f6 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Mon, 21 Feb 2022 19:23:11 +0000 Subject: [PATCH 122/212] Revert dimension changes to rand_pert. --- physics/module_mp_thompson.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 2478f828c..c23b6d1d8 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1288,11 +1288,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rand2 = 0.0 rand3 = 0.0 if (rand_perturb_on .ne. 0) then - if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,j) + if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1) m = RSHIFT(ABS(rand_perturb_on),1) - if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,j)*2. + 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,j)+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 88d0dd3939d3d1f65adb0ad4e9b0b51803ae1271 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 21 Feb 2022 15:33:34 -0700 Subject: [PATCH 123/212] change optional and explicitly-shaped SPP arrays to non-optional and assumed-shape in module_bl_mynn and module_sf_mynn --- physics/module_bl_mynn.F90 | 7 ++++--- physics/module_sf_mynn.F90 | 4 ++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index a492e50e0..3b0150e9e 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -4669,9 +4669,10 @@ SUBROUTINE mynn_bl_driver( & LOGICAL :: INITIALIZE_QKE ! Stochastic fields - INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col + 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 ! Substepping TKE INTEGER :: nsub diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index d1b3ce340..5f227750a 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -295,7 +295,8 @@ SUBROUTINE SFCLAY_mynn( & U3D,V3D, & th3d,pi3d - REAL, DIMENSION( ims:ime, kms:kme), OPTIONAL, & + !GJF: This array must be assumed-shape since it is conditionally-allocated + REAL, DIMENSION( :,: ), & INTENT(IN) :: pattern_spp_sfc !=================================== ! 2D VARIABLES @@ -3765,4 +3766,3 @@ REAL function psih_unstable(zolf,psi_opt) !======================================================================== END MODULE module_sf_mynn - From 242dcc985b031d875d59d59a1fc3d61c22c5fa00 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Tue, 22 Feb 2022 19:38:26 +0000 Subject: [PATCH 124/212] 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 125/212] 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 126/212] 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 127/212] 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 128/212] 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 129/212] 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 130/212] 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 131/212] 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 132/212] 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 133/212] 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 134/212] 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 135/212] 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 136/212] 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 137/212] 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 138/212] 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 139/212] 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 140/212] 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 141/212] 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 142/212] 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 143/212] 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 144/212] 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 145/212] 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 146/212] 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 147/212] 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 148/212] 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 149/212] 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 150/212] 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 151/212] 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 152/212] 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 153/212] 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 154/212] 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 155/212] 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 156/212] 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 157/212] 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 158/212] 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 159/212] 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 160/212] 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 161/212] 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 162/212] 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 163/212] 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 164/212] 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 165/212] 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 166/212] 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 167/212] 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 168/212] 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 169/212] 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 170/212] 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 171/212] 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 172/212] 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 173/212] 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 174/212] 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 175/212] 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 176/212] 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 177/212] 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 178/212] 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 179/212] 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 180/212] 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 181/212] 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 182/212] 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 183/212] 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 184/212] 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 185/212] 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 186/212] 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 8e6580eec9c890a0917b6d2c9063fafa0dd73b80 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 22 Mar 2022 20:33:14 +0000 Subject: [PATCH 187/212] 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 188/212] 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 81a326afa210c402144e9dddc56a45f85c745a70 Mon Sep 17 00:00:00 2001 From: helin wei Date: Thu, 24 Mar 2022 20:18:12 +0000 Subject: [PATCH 189/212] 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 190/212] 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 8f3c084264d49da54b7f4a7e0e202d966232e22a Mon Sep 17 00:00:00 2001 From: helin wei Date: Sat, 26 Mar 2022 03:19:48 +0000 Subject: [PATCH 191/212] 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 192/212] 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 193/212] 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 194/212] 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 195/212] 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 196/212] 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 197/212] 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 198/212] 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 199/212] 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 200/212] 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 201/212] 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 202/212] 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 203/212] 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 204/212] 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 205/212] 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 0aab5550cfb756a763c798a6f7d3decda23d70c6 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Fri, 8 Apr 2022 18:41:55 +0000 Subject: [PATCH 206/212] 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 c2754623fea3b851a5d5c77c9ebe93c117852828 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sun, 10 Apr 2022 21:04:14 -0600 Subject: [PATCH 207/212] 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 208/212] 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 3493525e5c1247ce7f9fba88bea9ff88614d4569 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 13 Apr 2022 17:34:07 -0400 Subject: [PATCH 209/212] 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 b6a03c8c23d903dcaaf379cce9c2f46c9d4ed95a Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 14 Apr 2022 11:49:58 -0400 Subject: [PATCH 210/212] 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 211/212] 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 1b8c8173ceaa311f93bb19131afe4dd007a0a6b5 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 20 Apr 2022 13:21:30 -0400 Subject: [PATCH 212/212] 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.