diff --git a/.gitmodules b/.gitmodules index 9dba021a80..ead0b930ba 100644 --- a/.gitmodules +++ b/.gitmodules @@ -101,11 +101,11 @@ [submodule "clubb"] path = src/physics/clubb - url = https://github.com/larson-group/clubb_release - fxrequired = AlwaysRequired - fxsparse = ../.clubb_sparse_checkout - fxtag = clubb_4ncar_20240605_73d60f6_gpufixes_posinf - fxDONOTUSEurl = https://github.com/larson-group/clubb_release + url = https://github.com/adamrher/clubb_release + fxrequired = AlwaysRequired + fxsparse = ../.clubb_sparse_checkout + fxtag = d224307f798b654f5312a9f035568c8a99ca400c + fxDONOTUSEurl = https://github.com/adamrher/clubb_release [submodule "cism"] path = components/cism diff --git a/bld/build-namelist b/bld/build-namelist index b9fd1328a1..3ad453567a 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -3146,6 +3146,7 @@ if (defined $cam_physpkg) { "This variable is set by build-namelist based on information\n". "from the configure cache file.\n"; } + $cam_physpkg = "'" . "$phys" . "'"; # add quotes to this string value $nl->set_variable_value('phys_ctl_nl', 'cam_physpkg', $cam_physpkg); @@ -3646,15 +3647,39 @@ if ($clubb_sgs =~ /$TRUE/io) { add_default($nl, 'clubb_wpxp_Ri_exp'); add_default($nl, 'clubb_z_displace'); + #Turn on HB scheme where CLUBB not active + add_default($nl, 'do_hb_above_clubb'); + #CLUBB+MF options add_default($nl, 'do_clubb_mf'); add_default($nl, 'do_clubb_mf_diag'); + add_default($nl, 'do_clubb_mf_rad'); + add_default($nl, 'do_clubb_mf_precip'); + add_default($nl, 'do_clubb_mf_addtke'); add_default($nl, 'clubb_mf_L0'); add_default($nl, 'clubb_mf_ent0'); + add_default($nl, 'clubb_mf_alphturb'); + add_default($nl, 'clubb_mf_Lopt'); + add_default($nl, 'clubb_mf_a0'); + add_default($nl, 'clubb_mf_b0'); add_default($nl, 'clubb_mf_nup'); - - #Turn on HB scheme where CLUBB not active - add_default($nl, 'do_hb_above_clubb'); + add_default($nl, 'clubb_mf_max_L0'); + add_default($nl, 'clubb_mf_fdd'); + add_default($nl, 'do_clubb_mf_coldpool'); + add_default($nl, 'clubb_mf_ddalph'); + add_default($nl, 'clubb_mf_ddbeta'); + add_default($nl, 'clubb_mf_pwfac'); + add_default($nl, 'clubb_mf_ddexp'); + add_default($nl, 'do_clubb_mf_ustar'); + add_default($nl, 'do_clubb_mf_mixd'); + add_default($nl, 'clubb_mf_up_ndt'); + add_default($nl, 'clubb_mf_cp_ndt'); + add_default($nl, 'do_clubb_mf_rhtke'); + add_default($nl, 'do_clubb_mf_cmt'); + add_default($nl, 'clubb_mf_kseed'); + add_default($nl, 'do_clubb_mf_lscale_perplume'); + add_default($nl, 'do_clubb_mf_coldpool_perplume'); + add_default($nl, 'do_clubb_mf_coldpool_init'); } # Tuning for wet scavenging of modal aerosols @@ -4513,7 +4538,6 @@ if ($docosp) { } } - my $offline_drv = $cfg->get('offline_drv'); if ($offline_drv ne 'stub') { diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 83333e0700..6c6a2bab91 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -2316,9 +2316,35 @@ .false. .false. + .false. + .false. + .false. 50.0 - 0.22 + 0.2 + 0.0 + 0 + 2.0 + 0.5 10 + 10.e3 + 0.0 + .false. + 2.e2 + 1.0 + 1.0 + 3.0 + 1.0 + .false. + .false. + 1 + 1 + .false. + .false. + .false. + .false. + .false. + 1 + .false. 10 @@ -2426,6 +2452,9 @@ 1 2 1 + + 6 + 6 1.0D0 @@ -2965,7 +2994,7 @@ 'T', 'bc_a1', 'bc_a4', 'dst_a1', 'dst_a2', 'dst_a3', 'ncl_a1', 'ncl_a2', 'ncl_a3', 'num_a1', 'num_a2', 'num_a3', 'num_a4', 'pom_a1', 'pom_a4', 'so4_a1', 'so4_a2', 'so4_a3', 'soa_a1', 'soa_a2' - + 'T', 'bc_a1', 'bc_a4', 'dst_a1', 'dst_a2', 'dst_a3', 'ncl_a1', 'ncl_a2', 'ncl_a3', 'num_a1', 'num_a2', 'num_a3', 'num_a4', 'pom_a1', 'pom_a4', 'so4_a1', 'so4_a2', 'so4_a3', 'soa_a1', 'soa_a2' @@ -3349,8 +3378,8 @@ .true. .true. - 2 - 1 + 2 + 1 3 3 @@ -3380,7 +3409,6 @@ 7 10 - 3 2 2 diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 1cfe3b794d..cb20b8f4c7 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -3160,7 +3160,7 @@ Default: .true. for CAM6; all others => .false. For small ice cloud concentrations, take the geometric mean of the iceopt=4 and iceopt=5 area fractions -Default: .true. for CAM_DEV; all others .false. +Default: .true. for CAM7; all others .false. + +If .true. turn on Suselj et al 2019 microphysics. +Default: .false. + + + +If .true. couple MF plumes to radiation +Default: .false. + + + +If .true. add MF contribution to TKE pbuf variable +Default: .false. + + Entrainment length scale in meters for individual plumes. Not used if @@ -4392,6 +4410,24 @@ do_clubb_mf=FALSE. Default: 50.0 + +Integer: dynamic entrainment length scale option +Default: 0 + + + +Real: linear coefficient relating ztop/cape to entrainment length scale +Default: 2.0 + + + +Real: exponential coefficient relating ztop/cape to entrainment length scale +Default: 0.5 + + Entrainment efficiency for individual plumes. Not used if @@ -4399,12 +4435,132 @@ do_clubb_mf=FALSE. Default: 0.22 + +Weighting factor for CLUBB TKE on plume entrainment +Default: 0.0 + + Real: number of plumes in mass flux ensemble Default: 10 + +Real: limiter on entrainment length scale + threshold to disable TKE enhanced entrainmnet +Default: 10.e3 + + + +Fraction of autoconversion partitioned to downdrafts (zero means no downdrafts) +Default: 0.0 + + + +If .true. turn on cold pool feedback parameterizations +Default: .false. + + + +Linear enhancement factor to the downdrafts used for the cold pool calculations +Default: 200.0 + + + +Exponent enhancement factor to the downdrafts used for the cold pool calculations +Default: 1.0 + + + +Enhancement factor for the near surface pressure drag term in downdraft equation +Default: 1.0 + + + +Elevation power law exponent for downdrafts velocities in the subcloud layer +Default: 3.0 + + + +Factor to increase the ensemble MF plume cloud fractions +Default: 1.0 + + + +If .true. use ustar for initializing the plume ensemble +Default: .false. + + + +If .true. use clubbmf mixing depth in place of the PBLH pbuf var +Default: .false. + + + +Real: number of time-steps for running average of the convective height scale +Default: 1 + + + +Real: number of time-steps for running average of cold pool effects +Default: 1 + + + +If .true. use relative humidity thresholds to turn off TKE enhanced entrainment +Default: .false. + + + +If .true. turn on convective momentum transport +Default: .false. + + + +If .true. set unique entrainment length scale for each plume member +Default: .false. + + + +If .true. let cold pool feedback impact plume intialization +Default: .false. + + + +If .true. set cold pool feedback to unique to each plume member +Default: .false. + + + +Real: level position of state used to seed the random number generator +Default: 1 + + + +If .true. turn on elevated convective initialization +Default: .false. + + = the maximum number of pbuf entries used. +type (snapshot_type_nd) :: pbuf_snapshot(350) contains diff --git a/src/cpl/nuopc/atm_comp_nuopc.F90 b/src/cpl/nuopc/atm_comp_nuopc.F90 index 3b19f50633..6dd494289a 100644 --- a/src/cpl/nuopc/atm_comp_nuopc.F90 +++ b/src/cpl/nuopc/atm_comp_nuopc.F90 @@ -1165,7 +1165,6 @@ subroutine ModelAdvance(gcomp, rc) call t_startf ('CAM_run1') call cam_run1 ( cam_in, cam_out ) call t_stopf ('CAM_run1') - end do if (mediator_present) then diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index d1cfa8efeb..402fd207ba 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -20,11 +20,11 @@ module clubb_intr use shr_kind_mod, only: r8=>shr_kind_r8 use ppgrid, only: pver, pverp, pcols, begchunk, endchunk use phys_control, only: phys_getopts - use physconst, only: cpair, gravit, rga, latvap, latice, zvir, rh2o, karman, pi, rair + use physconst, only: cpair, gravit, rga, latvap, latice, zvir, rh2o, karman, pi, rair, rhoh2o use air_composition, only: rairv, cpairv - use cam_history_support, only: max_fieldname_len + use cam_history_support, only: max_fieldname_len, fillvalue - use spmd_utils, only: masterproc + use spmd_utils, only: masterproc, iam !+++arh use constituents, only: pcnst, cnst_add, cnst_ndropmixed use atmos_phys_pbl_utils,only: calc_friction_velocity, calc_kinematic_heat_flux, calc_ideal_gas_rrho, & calc_kinematic_water_vapor_flux, calc_kinematic_buoyancy_flux, calc_obukhov_length @@ -37,7 +37,10 @@ module clubb_intr hm_metadata_type, sclr_idx_type use clubb_api_module, only: nparams - use clubb_mf, only: do_clubb_mf, do_clubb_mf_diag + use clubb_mf, only: do_clubb_mf, do_clubb_mf_diag, clubb_mf_nup, do_clubb_mf_rad, clubb_mf_Lopt, & + clubb_mf_ddalph, clubb_mf_up_ndt, clubb_mf_cp_ndt, do_clubb_mf_cmt, do_clubb_mf_addtke, & + clubb_mf_cldfrac_fac + use cam_history_support, only: add_hist_coord use cloud_fraction, only: dp1, dp2 #endif use scamMOD, only: single_column,scm_clubb_iop_name,scm_cambfb_mode @@ -418,6 +421,7 @@ module clubb_intr kvh_idx, & ! CLUBB eddy diffusivity on thermo levels pblh_idx, & ! PBL pbuf icwmrdp_idx, & ! In cloud mixing ratio for deep convection + icwmrsh_idx, & ! In cloud mixing ratio for shallow convection (MF) tke_idx, & ! turbulent kinetic energy tpert_idx, & ! temperature perturbation from PBL fice_idx, & ! fice_idx index in physics buffer @@ -481,6 +485,65 @@ module clubb_intr dnlfzm_idx = -1, & ! ZM detrained convective cloud water num concen. dnifzm_idx = -1 ! ZM detrained convective cloud ice num concen. + integer :: & + qtm_macmic1_idx, & + qtm_macmic2_idx, & + thlm_macmic1_idx, & + thlm_macmic2_idx, & + rcm_macmic_idx, & + cldfrac_macmic_idx, & + wpthlp_macmic_idx, & + wprtp_macmic_idx, & + wpthvp_macmic_idx, & + mf_wpthlp_macmic_idx, & + mf_wprtp_macmic_idx, & + mf_wpthvp_macmic_idx, & + up_macmic1_idx, & + up_macmic2_idx, & + dn_macmic1_idx, & + dn_macmic2_idx, & + upa_macmic1_idx, & + upa_macmic2_idx, & + dna_macmic1_idx, & + dna_macmic2_idx, & + thlu_macmic1_idx, & + thlu_macmic2_idx, & + qtu_macmic1_idx, & + qtu_macmic2_idx, & + thld_macmic1_idx, & + thld_macmic2_idx, & + qtd_macmic1_idx, & + qtd_macmic2_idx, & + dthl_macmic1_idx, & + dthl_macmic2_idx, & + dqt_macmic1_idx, & + dqt_macmic2_idx, & + dthlu_macmic1_idx, & + dthlu_macmic2_idx, & + dqtu_macmic1_idx, & + dqtu_macmic2_idx, & + dthld_macmic1_idx, & + dthld_macmic2_idx, & + dqtd_macmic1_idx, & + dqtd_macmic2_idx, & + ztop_macmic1_idx, & + ztop_macmic2_idx, & + ddcp_macmic1_idx, & + ddcp_macmic2_idx + + integer :: & + prec_sh_idx, & + snow_sh_idx + + integer :: ztopmn_idx + integer :: ztopma_idx + integer :: ztopm1_macmic_idx + integer :: ddcp_idx + integer :: ddcp_macmic_idx + integer :: ddcpmn_idx + integer :: cbm1_idx + integer :: cbm1_macmic_idx + ! Output arrays for CLUBB statistics real(r8), allocatable, dimension(:,:,:) :: out_zt, out_zm, out_radzt, out_radzm, out_sfc @@ -525,12 +588,15 @@ subroutine clubb_register_cam( ) use physics_buffer, only: pbuf_add_field, dtype_r8, dtype_i4, dyn_time_lvls use subcol_utils, only: subcol_get_scheme + integer :: cld_macmic_num_steps + !----- Begin Code ----- call phys_getopts( eddy_scheme_out = eddy_scheme, & deep_scheme_out = deep_scheme, & history_budget_out = history_budget, & history_budget_histfile_num_out = history_budget_histfile_num, & - do_hb_above_clubb_out = do_hb_above_clubb) + do_hb_above_clubb_out = do_hb_above_clubb, & + cld_macmic_num_steps_out = cld_macmic_num_steps) subcol_scheme = subcol_get_scheme() @@ -566,10 +632,10 @@ subroutine clubb_register_cam( ) call pbuf_add_field('QLST', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), qlst_idx) call pbuf_add_field('CONCLD', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), concld_idx) call pbuf_add_field('CLD', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cld_idx) - call pbuf_add_field('FICE', 'physpkg',dtype_r8, (/pcols,pver/), fice_idx) + call pbuf_add_field('FICE', 'global', dtype_r8, (/pcols,pver/), fice_idx) call pbuf_add_field('RAD_CLUBB', 'global', dtype_r8, (/pcols,pver/), radf_idx) - call pbuf_add_field('CMELIQ', 'physpkg',dtype_r8, (/pcols,pver/), cmeliq_idx) - call pbuf_add_field('QSATFAC', 'physpkg',dtype_r8, (/pcols,pver/), qsatfac_idx) + call pbuf_add_field('CMELIQ', 'global', dtype_r8, (/pcols,pver/), cmeliq_idx) + call pbuf_add_field('QSATFAC', 'global', dtype_r8, (/pcols,pver/), qsatfac_idx) call pbuf_add_field('WP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wp2_idx) @@ -639,6 +705,66 @@ subroutine clubb_register_cam( ) call pbuf_add_field('pdf_zm_var_w_2', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), pdf_zm_varnce_w_2_idx) call pbuf_add_field('pdf_zm_mixt_frac', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), pdf_zm_mixt_frac_idx) + ! these extrra coord vars don't seem to work for interpolate_output=.true. + call add_hist_coord('ncyc', cld_macmic_num_steps, 'macro/micro cycle index') + call add_hist_coord('nens', clubb_mf_nup, 'clubb+mf ensemble size') + + call pbuf_add_field('qtm_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), qtm_macmic1_idx) + call pbuf_add_field('qtm_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), qtm_macmic2_idx) + call pbuf_add_field('thlm_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), thlm_macmic1_idx) + call pbuf_add_field('thlm_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), thlm_macmic2_idx) + call pbuf_add_field('RCM_CLUBB_macmic' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), rcm_macmic_idx) + call pbuf_add_field('CLDFRAC_CLUBB_macmic','physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), cldfrac_macmic_idx) + call pbuf_add_field('WPTHLP_CLUBB_macmic' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), wpthlp_macmic_idx) + call pbuf_add_field('WPRTP_CLUBB_macmic' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), wpthvp_macmic_idx) + call pbuf_add_field('WPTHVP_CLUBB_macmic' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), wprtp_macmic_idx) + + if (do_clubb_mf) then + call pbuf_add_field('edmf_thlflx_macmic' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), mf_wpthlp_macmic_idx) + call pbuf_add_field('edmf_qtflx_macmic' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), mf_wprtp_macmic_idx) + call pbuf_add_field('edmf_thvflx_macmic' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), mf_wpthvp_macmic_idx) + call pbuf_add_field('ZTOPMN' ,'global' , dtype_r8, (/clubb_mf_up_ndt,pcols,clubb_mf_nup/), ztopmn_idx) + call pbuf_add_field('ZTOPMA' ,'global' , dtype_r8, (/pcols,clubb_mf_nup/), ztopma_idx) + call pbuf_add_field('ZTOP_MACMIC' ,'physpkg', dtype_r8, (/pcols,clubb_mf_nup/), ztopm1_macmic_idx) + call pbuf_add_field('DDCP' ,'global' , dtype_r8, (/pcols,clubb_mf_nup/), ddcp_idx) + call pbuf_add_field('DDCP_MACMIC' ,'physpkg', dtype_r8, (/pcols,clubb_mf_nup/), ddcp_macmic_idx) + call pbuf_add_field('DDCPMN' ,'global' , dtype_r8, (/clubb_mf_cp_ndt,pcols,clubb_mf_nup/), ddcpmn_idx) + call pbuf_add_field('CBM1' ,'global' , dtype_r8, (/pcols/), cbm1_idx) + call pbuf_add_field('CBM1_MACMIC' ,'physpkg', dtype_r8, (/pcols/), cbm1_macmic_idx) + call pbuf_add_field('up_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), up_macmic1_idx) + call pbuf_add_field('up_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), up_macmic2_idx) + call pbuf_add_field('dn_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), dn_macmic1_idx) + call pbuf_add_field('dn_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), dn_macmic2_idx) + call pbuf_add_field('upa_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), upa_macmic1_idx) + call pbuf_add_field('upa_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), upa_macmic2_idx) + call pbuf_add_field('dna_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), dna_macmic1_idx) + call pbuf_add_field('dna_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), dna_macmic2_idx) + call pbuf_add_field('thlu_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), thlu_macmic1_idx) + call pbuf_add_field('thlu_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), thlu_macmic2_idx) + call pbuf_add_field('qtu_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), qtu_macmic1_idx) + call pbuf_add_field('qtu_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), qtu_macmic2_idx) + call pbuf_add_field('thld_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), thld_macmic1_idx) + call pbuf_add_field('thld_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), thld_macmic2_idx) + call pbuf_add_field('qtd_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), qtd_macmic1_idx) + call pbuf_add_field('qtd_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), qtd_macmic2_idx) + call pbuf_add_field('dthl_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), dthl_macmic1_idx) + call pbuf_add_field('dthl_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), dthl_macmic2_idx) + call pbuf_add_field('dqt_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), dqt_macmic1_idx) + call pbuf_add_field('dqt_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps*clubb_mf_nup/), dqt_macmic2_idx) + call pbuf_add_field('dthlu_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), dthlu_macmic1_idx) + call pbuf_add_field('dthlu_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), dthlu_macmic2_idx) + call pbuf_add_field('dqtu_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), dqtu_macmic1_idx) + call pbuf_add_field('dqtu_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), dqtu_macmic2_idx) + call pbuf_add_field('dthld_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), dthld_macmic1_idx) + call pbuf_add_field('dthld_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), dthld_macmic2_idx) + call pbuf_add_field('dqtd_macmic1' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), dqtd_macmic1_idx) + call pbuf_add_field('dqtd_macmic2' ,'physpkg', dtype_r8, (/pcols,pverp*cld_macmic_num_steps/), dqtd_macmic2_idx) + call pbuf_add_field('ztop_macmic1' ,'physpkg', dtype_r8, (/pcols,cld_macmic_num_steps/), ztop_macmic1_idx) + call pbuf_add_field('ztop_macmic2' ,'physpkg', dtype_r8, (/pcols,cld_macmic_num_steps/), ztop_macmic2_idx) + call pbuf_add_field('ddcp_macmic1' ,'physpkg', dtype_r8, (/pcols,cld_macmic_num_steps/), ddcp_macmic1_idx) + call pbuf_add_field('ddcp_macmic2' ,'physpkg', dtype_r8, (/pcols,cld_macmic_num_steps/), ddcp_macmic2_idx) + end if + #endif end subroutine clubb_register_cam @@ -1471,6 +1597,8 @@ subroutine clubb_ini_cam(pbuf2d) ! The similar name to clubb_history is unfortunate... logical :: history_amwg, history_clubb + integer :: cld_macmic_num_steps + integer :: err_code ! Code for when CLUBB fails integer :: i, j, k, l ! Indices integer :: nmodes, nspec, m @@ -1533,7 +1661,8 @@ subroutine clubb_ini_cam(pbuf2d) call phys_getopts(history_amwg_out=history_amwg, & history_clubb_out=history_clubb, & - do_hb_above_clubb_out=do_hb_above_clubb) + do_hb_above_clubb_out=do_hb_above_clubb, & + cld_macmic_num_steps_out=cld_macmic_num_steps) ! Select variables to apply tendencies back to CAM @@ -1586,6 +1715,7 @@ subroutine clubb_ini_cam(pbuf2d) qist_idx = pbuf_get_index('QIST') ! Physical in-stratus IWC dp_frac_idx = pbuf_get_index('DP_FRAC') ! Deep convection cloud fraction icwmrdp_idx = pbuf_get_index('ICWMRDP') ! In-cloud deep convective mixing ratio + icwmrsh_idx = pbuf_get_index('ICWMRSH') ! In-cloud shallow convective mixing ratio (EDMF) sh_frac_idx = pbuf_get_index('SH_FRAC') ! Shallow convection cloud fraction relvar_idx = pbuf_get_index('RELVAR') ! Relative cloud water variance accre_enhan_idx = pbuf_get_index('ACCRE_ENHAN') ! accretion enhancement for MG @@ -1595,6 +1725,9 @@ subroutine clubb_ini_cam(pbuf2d) naai_idx = pbuf_get_index('NAAI') npccn_idx = pbuf_get_index('NPCCN') + ! CLUBB+MF + prec_sh_idx = pbuf_get_index('PREC_SH') + snow_sh_idx = pbuf_get_index('SNOW_SH') sclr_idx%iisclr_rt = -1 sclr_idx%iisclr_thl = -1 @@ -1833,31 +1966,127 @@ subroutine clubb_ini_cam(pbuf2d) call addfld ('ELEAK_CLUBB', horiz_only, 'A', 'W/m2', 'CLUBB energy leak', sampled_on_subcycle=.true.) call addfld ('TFIX_CLUBB', horiz_only, 'A', 'K', 'Temperature increment to conserve energy', sampled_on_subcycle=.true.) + call addfld ('TKE_CLUBB', (/ 'ilev' /), 'A', 'm2/s2', 'CLUBB tke on interface levels', sampled_on_subcycle=.true.) + ! ---------------------------------------------------------------------------- ! ! Below are for detailed analysis of EDMF Scheme ! ! ---------------------------------------------------------------------------- ! if (do_clubb_mf) then - call addfld ( 'edmf_DRY_A' , (/ 'ilev' /), 'A', 'fraction', 'Dry updraft area fraction (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_MOIST_A' , (/ 'ilev' /), 'A', 'fraction', 'Moist updraft area fraction (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_DRY_W' , (/ 'ilev' /), 'A', 'm/s' , 'Dry updraft vertical velocity (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_MOIST_W' , (/ 'ilev' /), 'A', 'm/s' , 'Moist updraft vertical velocity (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_DRY_QT' , (/ 'ilev' /), 'A', 'kg/kg' , 'Dry updraft total water mixing ratio (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_MOIST_QT' , (/ 'ilev' /), 'A', 'kg/kg' , 'Moist updraft total water mixing ratio (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_DRY_THL' , (/ 'ilev' /), 'A', 'K' , 'Dry updraft liquid-ice potential temperature (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_MOIST_THL', (/ 'ilev' /), 'A', 'K' , 'Moist updraft liquid-ice potential temperature (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_DRY_U' , (/ 'ilev' /), 'A', 'm/s' , 'Dry updraft zonal velocity (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_MOIST_U' , (/ 'ilev' /), 'A', 'm/s' , 'Moist updraft zonal velocity (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_DRY_V' , (/ 'ilev' /), 'A', 'm/s' , 'Dry updraft meridional velocity (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_MOIST_V' , (/ 'ilev' /), 'A', 'm/s' , 'Moist updraft meridional velocity (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_MOIST_QC' , (/ 'ilev' /), 'A', 'kg/kg' , 'Moist updraft condensate mixing ratio (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_S_AE' , (/ 'ilev' /), 'A', 'fraction', '1 minus sum of a_i*w_i (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_S_AW' , (/ 'ilev' /), 'A', 'm/s' , 'Sum of a_i*w_i (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_S_AWTHL' , (/ 'ilev' /), 'A', 'K m/s' , 'Sum of a_i*w_i*thl_i (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_S_AWQT' , (/ 'ilev' /), 'A', 'kgm/kgs' , 'Sum of a_i*w_i*q_ti (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_S_AWU' , (/ 'ilev' /), 'A', 'm2/s2' , 'Sum of a_i*w_i*u_i (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_S_AWV' , (/ 'ilev' /), 'A', 'm2/s2' , 'Sum of a_i*w_i*v_i (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_thlflx' , (/ 'ilev' /), 'A', 'W/m2' , 'thl flux (EDMF)', sampled_on_subcycle=.true.) - call addfld ( 'edmf_qtflx' , (/ 'ilev' /), 'A', 'W/m2' , 'qt flux (EDMF)', sampled_on_subcycle=.true.) + call addfld ( 'edmf_DRY_A' , (/ 'ilev' /), 'A', 'fraction', 'Dry updraft area fraction (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_MOIST_A' , (/ 'ilev' /), 'A', 'fraction', 'Moist updraft area fraction (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_DRY_W' , (/ 'ilev' /), 'A', 'm/s' , 'Dry updraft vertical velocity (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_MOIST_W' , (/ 'ilev' /), 'A', 'm/s' , 'Moist updraft vertical velocity (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_DRY_QT' , (/ 'ilev' /), 'A', 'kg/kg' , 'Dry updraft total water mixing ratio (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_MOIST_QT' , (/ 'ilev' /), 'A', 'kg/kg' , 'Moist updraft total water mixing ratio (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_DRY_THL' , (/ 'ilev' /), 'A', 'K' , 'Dry updraft liquid-ice potential temperature (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_MOIST_THL', (/ 'ilev' /), 'A', 'K' , 'Moist updraft liquid-ice potential temperature (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_DRY_U' , (/ 'ilev' /), 'A', 'm/s' , 'Dry updraft zonal velocity (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_MOIST_U' , (/ 'ilev' /), 'A', 'm/s' , 'Moist updraft zonal velocity (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_DRY_V' , (/ 'ilev' /), 'A', 'm/s' , 'Dry updraft meridional velocity (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_MOIST_V' , (/ 'ilev' /), 'A', 'm/s' , 'Moist updraft meridional velocity (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_MOIST_QC' , (/ 'ilev' /), 'A', 'kg/kg' , 'Moist updraft condensate mixing ratio (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_precc' , (/ 'ilev' /), 'A', 'm/s' , 'Moist updraft precipitation rate (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_S_AE' , (/ 'ilev' /), 'A', 'fraction', '1 minus sum of a_i*w_i (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_S_AW' , (/ 'ilev' /), 'A', 'm/s' , 'Sum of a_i*w_i (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_S_AWW' , (/ 'ilev' /), 'A', 'm2/s2' , 'Sum of a_i*w_i*w_i (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_S_AWTHL' , (/ 'ilev' /), 'A', 'K m/s' , 'Sum of a_i*w_i*thl_i (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_S_AWQT' , (/ 'ilev' /), 'A', 'kgm/kgs' , 'Sum of a_i*w_i*q_ti (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_S_AWTH' , (/ 'ilev' /), 'A', 'K m/s' , 'Sum of a_i*w_i*th_i (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_S_AWQV' , (/ 'ilev' /), 'A', 'kgm/kgs' , 'Sum of a_i*w_i*q_vi (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_S_AWU' , (/ 'ilev' /), 'A', 'm2/s2' , 'Sum of a_i*w_i*u_i (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_S_AWV' , (/ 'ilev' /), 'A', 'm2/s2' , 'Sum of a_i*w_i*v_i (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_thlforcup', (/ 'lev' /), 'A', 'K/s' , 'thl updraft forcing (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_qtforcup' , (/ 'lev' /), 'A', 'kg/kg/s' , 'qt updraft forcing (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_thlforcdn', (/ 'lev' /), 'A', 'K/s' , 'thl downdraft forcing (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_qtforcdn' , (/ 'lev' /), 'A', 'kg/kg/s' , 'qt downdraft forcing (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_thlforc' , (/ 'lev' /), 'A', 'K/s' , 'thl forcing (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_qtforc' , (/ 'lev' /), 'A', 'kg/kg/s' , 'qt forcing (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_thlflxup' , (/ 'ilev' /), 'A', 'K m/s' , 'thl updraft flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_qtflxup' , (/ 'ilev' /), 'A', 'kg/kg m/s', 'qt updraft flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_thlflxdn' , (/ 'ilev' /), 'A', 'K m/s' , 'thl downdraft flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_qtflxdn' , (/ 'ilev' /), 'A', 'kg/kg m/s', 'qt downdraft flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_thlflx' , (/ 'ilev' /), 'A', 'K m/s' , 'thl flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_qtflx' , (/ 'ilev' /), 'A', 'kg/kg m/s', 'qt flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_thvflx' , (/ 'ilev' /), 'A', 'K m/s' , 'thv flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_uflxup' , (/ 'ilev' /), 'A', 'm2/s2' , 'u updraft flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_vflxup' , (/ 'ilev' /), 'A', 'm2/s2' , 'v updraft flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_uflxdn' , (/ 'ilev' /), 'A', 'm2/s2' , 'u downdraft flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_vflxdn' , (/ 'ilev' /), 'A', 'm2/s2' , 'v downdraft flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_uflx' , (/ 'ilev' /), 'A', 'm2/s2' , 'u flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_vflx' , (/ 'ilev' /), 'A', 'm2/s2' , 'v flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_sqtup' , (/ 'lev' /), 'A', 'kg/kg/s' , 'Plume updraft microphysics tendency (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_sqtdn' , (/ 'lev' /), 'A', 'kg/kg/s' , 'Plume downdraft microphysics tendency (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_rcm' , (/ 'ilev' /), 'A', 'kg/kg' , 'grid mean cloud (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_cloudfrac', (/ 'lev' /), 'A', 'fraction', 'grid mean cloud fraction (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_ent' , (/ 'lev' /), 'A', '1/m' , 'ensemble mean entrainment (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_ztop' , horiz_only, 'A', 'm' , 'edmf ztop', flag_xyfill=.True., sampled_on_subcycle=.true.) + call addfld ( 'edmf_ddcp' , horiz_only, 'A', 'm/s' , 'edmf ddcp', flag_xyfill=.True., sampled_on_subcycle=.true.) + call addfld ( 'edmf_L0' , horiz_only, 'A', 'm' , 'edmf dynamic L0', flag_xyfill=.True., sampled_on_subcycle=.true.) + call addfld ( 'edmf_freq' , horiz_only, 'A', 'unitless', 'edmf frequency mf is active', flag_xyfill=.True., sampled_on_subcycle=.true.) + call addfld ( 'edmf_cfl' , horiz_only, 'A', 'unitless', 'max flux cfl number (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_cape' , horiz_only, 'A', 'J/kg' , 'ensemble mean CAPE (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_upa' , (/ 'ilev', 'nens' /), 'A', 'fraction', 'Plume updraft area fraction (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_upw' , (/ 'ilev', 'nens' /), 'A', 'm/s' , 'Plume updraft vertical velocity (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_upmf' , (/ 'ilev', 'nens' /), 'A', 'kg/m2/s' , 'Plume updraft mass flux (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_upqt' , (/ 'ilev', 'nens' /), 'A', 'kg/kg' , 'Plume updraft total water mixing ratio (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_upthl' , (/ 'ilev', 'nens' /), 'A', 'K' , 'Plume updraft liquid potential temperature (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_upthv' , (/ 'ilev', 'nens' /), 'A', 'm/s' , 'Plume updraft virtual potential temperature (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_upth' , (/ 'ilev', 'nens' /), 'A', 'm/s' , 'Plume updraft potential temperature (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_upqc' , (/ 'ilev', 'nens' /), 'A', 'kg/kg' , 'Plume updraft condensate mixing ratio (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_upent' , (/ 'ilev', 'nens' /), 'A', '1/m' , 'Plume updraft entrainment rate (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_updet' , (/ 'ilev', 'nens' /), 'A', '1/m' , 'Plume updraft dettrainment rate (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_upbuoy' , (/ 'ilev', 'nens' /), 'A', 'm/s2' , 'Plume updraft buoyancy (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_dnw' , (/ 'ilev', 'nens' /), 'A', 'm/s' , 'Plume downdraft vertical velocity (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_dnthl' , (/ 'ilev', 'nens' /), 'A', 'K' , 'Plume downdraft liquid potential temperature (EDMF)', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_dnqt' , (/ 'ilev', 'nens' /), 'A', 'kg/kg' , 'Plume downdraft total water mixing ratio (EDMF)', sampled_on_subcycle=.true. ) + end if + + call addfld ('qtm_macmic1' , (/ 'ilev', 'ncyc' /), 'A', 'kg/kg' , 'QT at macro/micro substep', sampled_on_subcycle=.true.) + call addfld ('qtm_macmic2' , (/ 'ilev', 'ncyc' /), 'A', 'kg/kg' , 'QT at macro/micro substep', sampled_on_subcycle=.true.) + call addfld ('thlm_macmic1' , (/ 'ilev', 'ncyc' /), 'A', 'K' , 'THETAL at macro/micro substep', sampled_on_subcycle=.true.) + call addfld ('thlm_macmic2' , (/ 'ilev', 'ncyc' /), 'A', 'K' , 'THETAL at macro/micro substep', sampled_on_subcycle=.true.) + call addfld ('RCM_CLUBB_macmic' , (/ 'ilev', 'ncyc' /), 'A', 'kg/kg' , 'RCM CLUBB at macro/micro substep', sampled_on_subcycle=.true.) + call addfld ('CLDFRAC_CLUBB_macmic', (/ 'ilev', 'ncyc' /), 'A', 'fraction', 'CLDFRAC CLUBB at macro/micro substep', sampled_on_subcycle=.true.) + call addfld ('WPTHLP_CLUBB_macmic' , (/ 'ilev', 'ncyc' /), 'A', 'W/m2' , 'Heat Flux at macro/micro substep', sampled_on_subcycle=.true.) + call addfld ('WPRTP_CLUBB_macmic' , (/ 'ilev', 'ncyc' /), 'A', 'W/m2' , 'Moisture Flux at macro/micro substep', sampled_on_subcycle=.true.) + call addfld ('WPTHVP_CLUBB_macmic' , (/ 'ilev', 'ncyc' /), 'A', 'W/m2' , 'Buoyancy Flux at macro/micro substep', sampled_on_subcycle=.true.) + + if (do_clubb_mf) then + call addfld ( 'edmf_thlflx_macmic', (/ 'ilev', 'ncyc' /), 'A', 'K m/s' , 'thl flux (EDMF) at macro/micro substep', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_thvflx_macmic', (/ 'ilev', 'ncyc' /), 'A', 'K m/s' , 'thv flux (EDMF) at macro/micro substep', sampled_on_subcycle=.true. ) + call addfld ( 'edmf_qtflx_macmic' , (/ 'ilev', 'ncyc' /), 'A', 'kg/kg m/s' , 'qt flux (EDMF) at macro/micro substep', sampled_on_subcycle=.true. ) + call addfld ( 'up_macmic1', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'up', sampled_on_subcycle=.true. ) + call addfld ( 'up_macmic2', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'up', sampled_on_subcycle=.true. ) + call addfld ( 'dn_macmic1', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'dn', sampled_on_subcycle=.true. ) + call addfld ( 'dn_macmic2', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'dn', sampled_on_subcycle=.true. ) + call addfld ( 'upa_macmic1', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'fraction' , 'upa', sampled_on_subcycle=.true. ) + call addfld ( 'upa_macmic2', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'fraction' , 'upa', sampled_on_subcycle=.true. ) + call addfld ( 'dna_macmic1', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'fraction' , 'dna', sampled_on_subcycle=.true. ) + call addfld ( 'dna_macmic2', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'fraction' , 'dna', sampled_on_subcycle=.true. ) + call addfld ( 'thlu_macmic1', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'thl up', sampled_on_subcycle=.true. ) + call addfld ( 'thlu_macmic2', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'thl up', sampled_on_subcycle=.true. ) + call addfld ( 'qtu_macmic1', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'qt up', sampled_on_subcycle=.true. ) + call addfld ( 'qtu_macmic2', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'qt up', sampled_on_subcycle=.true. ) + call addfld ( 'thld_macmic1', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'thl dn', sampled_on_subcycle=.true. ) + call addfld ( 'thld_macmic2', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'thl dn', sampled_on_subcycle=.true. ) + call addfld ( 'qtd_macmic1', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'qt dn', sampled_on_subcycle=.true. ) + call addfld ( 'qtd_macmic2', (/ 'ilev', 'nens', 'ncyc' /), 'I', 'm/s' , 'qt dn', sampled_on_subcycle=.true. ) + call addfld ( 'dthl_macmic1', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'thl tend', sampled_on_subcycle=.true. ) + call addfld ( 'dthl_macmic2', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'thl tend', sampled_on_subcycle=.true. ) + call addfld ( 'dqt_macmic1', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'qt tend', sampled_on_subcycle=.true. ) + call addfld ( 'dqt_macmic2', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'qt tend', sampled_on_subcycle=.true. ) + call addfld ( 'dthlu_macmic1', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'thl up tend', sampled_on_subcycle=.true. ) + call addfld ( 'dthlu_macmic2', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'thl up tend', sampled_on_subcycle=.true. ) + call addfld ( 'dqtu_macmic1', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'qt up tend', sampled_on_subcycle=.true. ) + call addfld ( 'dqtu_macmic2', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'qt up tend', sampled_on_subcycle=.true. ) + call addfld ( 'dthld_macmic1', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'thl dn tend', sampled_on_subcycle=.true. ) + call addfld ( 'dthld_macmic2', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'thl dn tend', sampled_on_subcycle=.true. ) + call addfld ( 'dqtd_macmic1', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'qt dn tend', sampled_on_subcycle=.true. ) + call addfld ( 'dqtd_macmic2', (/ 'ilev', 'ncyc' /), 'I', 'm/s' , 'qt dn tend', sampled_on_subcycle=.true. ) + call addfld ( 'ztop_macmic1', (/ 'ncyc' /), 'I', 'm/s' , 'ztop', sampled_on_subcycle=.true. ) + call addfld ( 'ztop_macmic2', (/ 'ncyc' /), 'I', 'm/s' , 'ztop', sampled_on_subcycle=.true. ) + call addfld ( 'ddcp_macmic1', (/ 'ncyc' /), 'I', 'm/s' , 'ddcp', sampled_on_subcycle=.true. ) + call addfld ( 'ddcp_macmic2', (/ 'ncyc' /), 'I', 'm/s' , 'ddcp', sampled_on_subcycle=.true. ) end if if ( trim(subcol_scheme) /= 'SILHS' ) then @@ -1948,27 +2177,64 @@ subroutine clubb_ini_cam(pbuf2d) end if if (do_clubb_mf_diag) then - call add_default( 'edmf_DRY_A' , 1, ' ') - call add_default( 'edmf_MOIST_A' , 1, ' ') - call add_default( 'edmf_DRY_W' , 1, ' ') - call add_default( 'edmf_MOIST_W' , 1, ' ') - call add_default( 'edmf_DRY_QT' , 1, ' ') - call add_default( 'edmf_MOIST_QT' , 1, ' ') - call add_default( 'edmf_DRY_THL' , 1, ' ') - call add_default( 'edmf_MOIST_THL', 1, ' ') - call add_default( 'edmf_DRY_U' , 1, ' ') - call add_default( 'edmf_MOIST_U' , 1, ' ') - call add_default( 'edmf_DRY_V' , 1, ' ') - call add_default( 'edmf_MOIST_V' , 1, ' ') - call add_default( 'edmf_MOIST_QC' , 1, ' ') - call add_default( 'edmf_S_AE' , 1, ' ') - call add_default( 'edmf_S_AW' , 1, ' ') - call add_default( 'edmf_S_AWTHL' , 1, ' ') - call add_default( 'edmf_S_AWQT' , 1, ' ') - call add_default( 'edmf_S_AWU' , 1, ' ') - call add_default( 'edmf_S_AWV' , 1, ' ') - call add_default( 'edmf_thlflx' , 1, ' ') - call add_default( 'edmf_qtflx' , 1, ' ') + call add_default( 'edmf_DRY_A' , 1, ' ') + call add_default( 'edmf_MOIST_A' , 1, ' ') + call add_default( 'edmf_DRY_W' , 1, ' ') + call add_default( 'edmf_MOIST_W' , 1, ' ') + call add_default( 'edmf_DRY_QT' , 1, ' ') + call add_default( 'edmf_MOIST_QT' , 1, ' ') + call add_default( 'edmf_DRY_THL' , 1, ' ') + call add_default( 'edmf_MOIST_THL', 1, ' ') + call add_default( 'edmf_DRY_U' , 1, ' ') + call add_default( 'edmf_MOIST_U' , 1, ' ') + call add_default( 'edmf_DRY_V' , 1, ' ') + call add_default( 'edmf_MOIST_V' , 1, ' ') + call add_default( 'edmf_MOIST_QC' , 1, ' ') + call add_default( 'edmf_precc' , 1, ' ') + call add_default( 'edmf_S_AE' , 1, ' ') + call add_default( 'edmf_S_AW' , 1, ' ') + call add_default( 'edmf_S_AWW' , 1, ' ') + call add_default( 'edmf_S_AWTH' , 1, ' ') + call add_default( 'edmf_S_AWTHL' , 1, ' ') + call add_default( 'edmf_S_AWQT' , 1, ' ') + call add_default( 'edmf_S_AWU' , 1, ' ') + call add_default( 'edmf_S_AWV' , 1, ' ') + call add_default( 'edmf_thlflxup' , 1, ' ') + call add_default( 'edmf_qtflxup' , 1, ' ') + call add_default( 'edmf_thlflxdn' , 1, ' ') + call add_default( 'edmf_qtflxdn' , 1, ' ') + call add_default( 'edmf_thlflx' , 1, ' ') + call add_default( 'edmf_thvflx' , 1, ' ') + call add_default( 'edmf_uflxup' , 1, ' ') + call add_default( 'edmf_vflxup' , 1, ' ') + call add_default( 'edmf_uflxdn' , 1, ' ') + call add_default( 'edmf_vflxdn' , 1, ' ') + call add_default( 'edmf_uflx' , 1, ' ') + call add_default( 'edmf_vflx' , 1, ' ') + call add_default( 'edmf_qtflx' , 1, ' ') + + call add_default( 'edmf_thlforcup', 1, ' ') + call add_default( 'edmf_qtforcup' , 1, ' ') + call add_default( 'edmf_thlforcdn', 1, ' ') + call add_default( 'edmf_qtforcdn' , 1, ' ') + + call add_default( 'edmf_thlforc' , 1, ' ') + call add_default( 'edmf_qtforc' , 1, ' ') + call add_default( 'edmf_sqtup' , 1, ' ') + call add_default( 'edmf_sqtdn' , 1, ' ') + call add_default( 'edmf_rcm' , 1, ' ') + call add_default( 'edmf_cloudfrac', 1, ' ') + call add_default( 'edmf_ent' , 1, ' ') + call add_default( 'edmf_ztop' , 1, ' ') + call add_default( 'edmf_ddcp' , 1, ' ') + call add_default( 'edmf_L0' , 1, ' ') + call add_default( 'edmf_freq' , 1, ' ') + call add_default( 'edmf_cape' , 1, ' ') + call add_default( 'edmf_cfl' , 1, ' ') + + call add_default( 'edmf_thlflx_macmic' , 1, ' ') + call add_default( 'edmf_qtflx_macmic' , 1, ' ') + call add_default( 'edmf_thvflx_macmic' , 1, ' ') end if if (history_budget) then @@ -2030,6 +2296,54 @@ subroutine clubb_ini_cam(pbuf2d) call pbuf_set_field(pbuf2d, wp2vp2_idx, 0.0_r8) call pbuf_set_field(pbuf2d, ice_supersat_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, thlm_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, thlm_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, qtm_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, qtm_macmic2_idx, 0.0_r8) + + if (do_clubb_mf) then + call pbuf_set_field(pbuf2d, ztopmn_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, ztopma_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, ztopm1_macmic_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, ddcp_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, ddcp_macmic_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, ddcpmn_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, cbm1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, cbm1_macmic_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, up_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, up_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dn_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dn_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, upa_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, upa_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dna_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dna_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, thlu_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, thlu_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, qtu_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, qtu_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, thld_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, thld_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, qtd_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, qtd_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dthl_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dthl_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dqt_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dqt_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dthlu_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dthlu_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dqtu_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dqtu_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dthld_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dthld_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dqtd_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, dqtd_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, ztop_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, ztop_macmic2_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, ddcp_macmic1_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, ddcp_macmic2_idx, 0.0_r8) + end if + ! Initialize SILHS covariance contributions call pbuf_set_field(pbuf2d, rtp2_mc_zt_idx, 0.0_r8) call pbuf_set_field(pbuf2d, thlp2_mc_zt_idx, 0.0_r8) @@ -2104,6 +2418,9 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & use time_manager, only: get_nstep, is_first_restart_step use perf_mod, only: t_startf, t_stopf + use wv_saturation, only: qsat + use interpolate_data,only: vertinterp + #ifdef CLUBB_SGS use holtslag_boville_diff, only: hb_pbl_dependent_coefficients_run use clubb_api_module, only: & @@ -2127,7 +2444,8 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & pdf_parameter, & init_pdf_params_api, & init_pdf_implicit_coefs_terms_api, & - setup_grid_api + setup_grid_api, & + ic_K use clubb_api_module, only: & clubb_fatal_error ! Error code value to indicate a fatal error @@ -2274,6 +2592,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & rtm_in, & ! total water mixing ratio [kg/kg] wprtp_in, & ! turbulent flux of total water [kg/kg m/s] wpthlp_in, & ! turbulent flux of thetal [K m/s] + tke_in, & ! TKE [m^2/s^2] wp2_in, & ! vertical velocity variance (CLUBB) [m^2/s^2] wp3_in, & ! third moment vertical velocity [m^3/s^3] rtp2_in, & ! total water variance [kg^2/kg^2] @@ -2298,6 +2617,8 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & vpwp_pert_inout, & ! Perturbed v'w' [m^2/s^2] khzm_out, & ! Eddy diffusivity of heat/moisture on momentum (i.e. interface) levels [m^2/s] khzt_out, & ! eddy diffusivity on thermo grids [m^2/s] +!+++arh + Lscale_out, & qclvar_out, & ! cloud water variance [kg^2/kg^2] thlprcp_out, & wprcp_out, & ! CLUBB output of flux of liquid water [kg/kg m/s] @@ -2470,6 +2791,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & real(r8), pointer, dimension(:) :: pblh ! planetary boundary layer height [m] real(r8), pointer, dimension(:,:) :: tke ! turbulent kinetic energy [m^2/s^2] real(r8), pointer, dimension(:,:) :: dp_icwmr ! deep convection in cloud mixing ratio [kg/kg] + real(r8), pointer, dimension(:,:) :: sh_icwmr ! shallow convection (EDMF) in cloud mixing ratio [kg/kg] real(r8), pointer, dimension(:,:) :: ice_supersat_frac ! Cloud fraction of ice clouds (pverp)[fraction] real(r8), pointer, dimension(:,:) :: relvar ! relative cloud water variance [-] real(r8), pointer, dimension(:,:) :: accre_enhan ! accretion enhancement factor [-] @@ -2523,6 +2845,115 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & logical :: lqice(pcnst) logical :: apply_to_surface(pcols) + ! CLUBB-MF pointers + real(r8),pointer :: prec_sh(:) ! total precipitation from MF + real(r8),pointer :: snow_sh(:) ! snow from MF + + real(r8), pointer :: ztopmn(:,:,:) + real(r8), pointer :: ztopma(:,:) + real(r8), pointer :: ztopm1_macmic(:,:) + real(r8), pointer :: ddcp(:,:) + real(r8), pointer :: ddcp_macmic(:,:) + real(r8), pointer :: ddcpmn(:,:,:) + + real(r8), pointer :: cbm1(:) + real(r8), pointer :: cbm1_macmic(:) + + real(r8), pointer :: qtm_macmic1(:,:) + real(r8), pointer :: qtm_macmic2(:,:) + real(r8), pointer :: thlm_macmic1(:,:) + real(r8), pointer :: thlm_macmic2(:,:) + real(r8), pointer :: rcm_macmic(:,:) + real(r8), pointer :: cldfrac_macmic(:,:) + real(r8), pointer :: wpthlp_macmic(:,:) + real(r8), pointer :: wprtp_macmic(:,:) + real(r8), pointer :: wpthvp_macmic(:,:) + real(r8), pointer :: mf_thlflx_macmic(:,:) + real(r8), pointer :: mf_qtflx_macmic(:,:) + real(r8), pointer :: mf_thvflx_macmic(:,:) + real(r8), pointer :: up_macmic1(:,:) + real(r8), pointer :: up_macmic2(:,:) + real(r8), pointer :: dn_macmic1(:,:) + real(r8), pointer :: dn_macmic2(:,:) + real(r8), pointer :: upa_macmic1(:,:) + real(r8), pointer :: upa_macmic2(:,:) + real(r8), pointer :: dna_macmic1(:,:) + real(r8), pointer :: dna_macmic2(:,:) + real(r8), pointer :: thlu_macmic1(:,:) + real(r8), pointer :: thlu_macmic2(:,:) + real(r8), pointer :: qtu_macmic1(:,:) + real(r8), pointer :: qtu_macmic2(:,:) + real(r8), pointer :: thld_macmic1(:,:) + real(r8), pointer :: thld_macmic2(:,:) + real(r8), pointer :: qtd_macmic1(:,:) + real(r8), pointer :: qtd_macmic2(:,:) + real(r8), pointer :: dthl_macmic1(:,:) + real(r8), pointer :: dthl_macmic2(:,:) + real(r8), pointer :: dqt_macmic1(:,:) + real(r8), pointer :: dqt_macmic2(:,:) + real(r8), pointer :: dthlu_macmic1(:,:) + real(r8), pointer :: dthlu_macmic2(:,:) + real(r8), pointer :: dqtu_macmic1(:,:) + real(r8), pointer :: dqtu_macmic2(:,:) + real(r8), pointer :: dthld_macmic1(:,:) + real(r8), pointer :: dthld_macmic2(:,:) + real(r8), pointer :: dqtd_macmic1(:,:) + real(r8), pointer :: dqtd_macmic2(:,:) + real(r8), pointer :: ztop_macmic1(:,:) + real(r8), pointer :: ztop_macmic2(:,:) + real(r8), pointer :: ddcp_macmic1(:,:) + real(r8), pointer :: ddcp_macmic2(:,:) + + ! + ! MF outputs to outfld + real(r8), dimension(pcols) :: mf_ztop_output, mf_L0_output, & + mf_cape_output, mf_cfl_output, & + mf_ddcp_output, mf_freq_output + + real(r8), dimension(pcols,pver) :: mf_thlforcup_output, mf_qtforcup_output, & ! thermodynamic grid + mf_thlforcdn_output, mf_qtforcdn_output, & ! thermodynamic grid + mf_thlforc_output, mf_qtforc_output, & ! thermodynamic grid + mf_ent_output, & ! thermodynamic grid + mf_sqtup_output, mf_sqtdn_output, & ! thermodynamic grid + mf_qc_output, mf_cloudfrac_output ! thermodynamic grid + + ! MF plume level outputs + real(r8), dimension(pcols,pverp,clubb_mf_nup) :: mf_upa_flip, & + mf_upw_flip, & + mf_upmf_flip, & + mf_upqt_flip, & + mf_upthl_flip, & + mf_upthv_flip, & + mf_upth_flip, & + mf_upqc_flip, & + mf_upbuoy_flip, & + mf_upent_flip, & + mf_updet_flip + ! MF plume level outputs to outfld + real(r8), dimension(pcols,pverp*clubb_mf_nup) :: mf_upa_output, & + mf_upw_output, & + mf_upmf_output, & + mf_upqt_output, & + mf_upthl_output, & + mf_upthv_output, & + mf_upth_output, & + mf_upqc_output, & + mf_upent_output, & + mf_updet_output, & + mf_upbuoy_output + ! MF plume level outputs + real(r8), dimension(pcols,pverp,clubb_mf_nup) :: mf_dnw_flip, & + mf_dnthl_flip, & + mf_dnqt_flip + + ! MF plume level outputs to outfld + real(r8), dimension(pcols,pverp*clubb_mf_nup) :: mf_dnw_output, & + mf_dnthl_output, & + mf_dnqt_output + + ! MF Plume + real(r8), pointer :: tpert(:) + ! MF outputs to outfld ! NOTE: Arrays of size PCOLS (all possible columns) can be used to access State, PBuf and History Subroutines real(r8), dimension(pcols,pverp) :: mf_dry_a_output, mf_moist_a_output, & @@ -2533,34 +2964,102 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & mf_dry_v_output, mf_moist_v_output, & mf_moist_qc_output, & s_ae_output, s_aw_output, & + s_awthlup_output, s_awqtup_output, s_awuup_output, s_awvup_output, & + s_awthldn_output, s_awqtdn_output, s_awudn_output, s_awvdn_output, & s_awthl_output, s_awqt_output, & - s_awql_output, s_awqi_output, & s_awu_output, s_awv_output, & - mf_thlflx_output, mf_qtflx_output - ! MF Plume - ! NOTE: Arrays of size PCOLS (all possible columns) can be used to access State, PBuf and History Subroutines - real(r8), dimension(pcols,pverp) :: mf_dry_a, mf_moist_a, & + s_aww_output, & + mf_thlflxup_output,mf_qtflxup_output, mf_uflxup_output, mf_vflxup_output, & + mf_thlflxdn_output,mf_qtflxdn_output, mf_uflxdn_output, mf_vflxdn_output, & + mf_thlflx_output, mf_qtflx_output, mf_uflx_output, mf_vflx_output, & + mf_thvflx_output, & + mf_rcm_output, mf_precc_output + ! MF work arrays (of size NCOL) + real(r8), dimension(state%ncol,pverp):: mf_dry_a, mf_moist_a, & mf_dry_w, mf_moist_w, & mf_dry_qt, mf_moist_qt, & mf_dry_thl, mf_moist_thl, & mf_dry_u, mf_moist_u, & mf_dry_v, mf_moist_v, & mf_moist_qc, & - s_ae, s_aw, & + s_ae, s_ac, & + s_aup, s_adn, & + s_aw, & + s_awup, s_awdn, & + s_aww, & + s_awwup, s_awwdn, & + s_awthlup, s_awqtup, s_awuup, s_awvup, & + s_awthldn, s_awqtdn, s_awudn, s_awvdn, & s_awthl, s_awqt, & - s_awql, s_awqi, & s_awu, s_awv, & - mf_thlflx, mf_qtflx - - real(r8) :: inv_rh2o ! To reduce the number of divisions in clubb_tend - - ! MF local vars - real(r8), dimension(pcols,pverp) :: rtm_zm_in, thlm_zm_in, & ! momentum grid + mf_sqtup, mf_sthlup, & + mf_sqtdn, mf_sthldn, & + mf_sqt, mf_sthl, & + mf_precc + + real(r8), dimension(state%ncol,pverp) :: mf_thlflxup, mf_qtflxup, mf_uflxup, mf_vflxup, & + mf_thlflxdn, mf_qtflxdn, mf_uflxdn, mf_vflxdn, & + mf_thlflx, mf_qtflx, mf_uflx, mf_vflx, & + mf_thvflx, & + mf_thlforcup, mf_qtforcup, & + mf_thlforcdn, mf_qtforcdn, & + mf_thlforcup_nadv,mf_qtforcup_nadv, & + mf_thlforcdn_nadv,mf_qtforcdn_nadv, & + mf_thlforc_nadv, mf_qtforc_nadv, & + mf_qc, mf_cloudfrac, & + mf_qc_nadv, mf_cloudfrac_nadv, & + mf_qc_zt, mf_cloudfrac_zt, & + mf_rcm, mf_rcm_nadv, & + mf_ent_nadv + + real(r8), dimension(state%ncol,pverp,clubb_mf_nup) :: mf_upa, mf_dna, & + mf_upw, mf_dnw, & + mf_upmf, & + mf_upqt, mf_dnqt, & + mf_upthl, mf_dnthl, & + mf_upthv, mf_dnthv, & + mf_upth, mf_dnth, & + mf_upqc, mf_dnqc, & + mf_upbuoy, & + mf_updet, & + mf_upent + + real(r8), dimension(state%ncol,pverp,clubb_mf_nup) :: flip + real(r8), dimension(state%ncol,pverp) :: lilflip + + ! CFL limiter vars + real(r8), parameter :: cflval = 1._r8 + integer :: trop_mf + real(r8) :: lambda + real(r8), dimension(state%ncol) :: cflfac, max_cfl, & + th_sfc, max_cfl_nadv + logical :: cfllim + + + real(r8), dimension(state%ncol) :: mf_precc_nadv, mf_snow_nadv,& + mf_cbm1, mf_cbm1_nadv, & + mf_freq_nadv + + real(r8), dimension(state%ncol,clubb_mf_nup) :: mf_ztop, mf_ztop_nadv, & + mf_ztopm1, mf_ztopm1_nadv, & + mf_L0, mf_L0_nadv, & + mf_ddcp, mf_ddcp_nadv + + real(r8), dimension(state%ncol,pver) :: esat, rh + real(r8), dimension(state%ncol,pver) :: mq, mqsat + real(r8), dimension(state%ncol) :: rhlev, rhinv + + real(r8), dimension(state%ncol,pverp):: rtm_zm_in, thlm_zm_in, & ! momentum grid dzt, invrs_dzt, & ! thermodynamic grid invrs_exner_zt,& ! thermodynamic grid kappa_zt, qc_zt, & ! thermodynamic grid + th_zt, qv_zt, & ! momentum grid + th_zm, qv_zm, & ! momentum grid + qc_zm, & ! momentum grid kappa_zm, p_in_Pa_zm, & ! momentum grid - invrs_exner_zm ! momentum grid + dzm, invrs_exner_zm ! momentum grid + + real(r8) :: inv_rh2o ! To reduce the number of divisions in clubb_tend real(r8) :: temp2d(pcols,pver), temp2dp(pcols,pverp) ! temporary array for holding scaled outputs @@ -2712,8 +3211,74 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call pbuf_get_field(pbuf, kvh_idx, khzm) call pbuf_get_field(pbuf, pblh_idx, pblh) call pbuf_get_field(pbuf, icwmrdp_idx, dp_icwmr) + call pbuf_get_field(pbuf, icwmrsh_idx, sh_icwmr) call pbuf_get_field(pbuf, cmfmc_sh_idx, cmfmc_sh) + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh ) + call pbuf_get_field(pbuf, snow_sh_idx, snow_sh ) + + call pbuf_get_field(pbuf, qtm_macmic1_idx, qtm_macmic1) + call pbuf_get_field(pbuf, qtm_macmic2_idx, qtm_macmic2) + call pbuf_get_field(pbuf, thlm_macmic1_idx, thlm_macmic1) + call pbuf_get_field(pbuf, thlm_macmic2_idx, thlm_macmic2) + + call pbuf_get_field(pbuf, rcm_macmic_idx, rcm_macmic) + call pbuf_get_field(pbuf, cldfrac_macmic_idx, cldfrac_macmic) + call pbuf_get_field(pbuf, wpthlp_macmic_idx, wpthlp_macmic) + call pbuf_get_field(pbuf, wprtp_macmic_idx, wprtp_macmic) + call pbuf_get_field(pbuf, wpthvp_macmic_idx, wpthvp_macmic) + + if (do_clubb_mf) then + call pbuf_get_field(pbuf, mf_wpthlp_macmic_idx, mf_thlflx_macmic) + call pbuf_get_field(pbuf, mf_wprtp_macmic_idx, mf_qtflx_macmic) + call pbuf_get_field(pbuf, mf_wpthvp_macmic_idx, mf_thvflx_macmic) + call pbuf_get_field(pbuf, tpert_idx, tpert) + + call pbuf_get_field(pbuf, ztopmn_idx, ztopmn) + call pbuf_get_field(pbuf, ztopma_idx, ztopma) + call pbuf_get_field(pbuf, ztopm1_macmic_idx, ztopm1_macmic) + + call pbuf_get_field(pbuf, ddcp_idx, ddcp) + call pbuf_get_field(pbuf, ddcp_macmic_idx, ddcp_macmic) + call pbuf_get_field(pbuf, ddcpmn_idx, ddcpmn) + + call pbuf_get_field(pbuf, cbm1_idx, cbm1) + call pbuf_get_field(pbuf, cbm1_macmic_idx, cbm1_macmic) + + call pbuf_get_field(pbuf, up_macmic1_idx, up_macmic1) + call pbuf_get_field(pbuf, up_macmic2_idx, up_macmic2) + call pbuf_get_field(pbuf, dn_macmic1_idx, dn_macmic1) + call pbuf_get_field(pbuf, dn_macmic2_idx, dn_macmic2) + call pbuf_get_field(pbuf, upa_macmic1_idx, upa_macmic1) + call pbuf_get_field(pbuf, upa_macmic2_idx, upa_macmic2) + call pbuf_get_field(pbuf, dna_macmic1_idx, dna_macmic1) + call pbuf_get_field(pbuf, dna_macmic2_idx, dna_macmic2) + call pbuf_get_field(pbuf, thlu_macmic1_idx, thlu_macmic1) + call pbuf_get_field(pbuf, thlu_macmic2_idx, thlu_macmic2) + call pbuf_get_field(pbuf, qtu_macmic1_idx, qtu_macmic1) + call pbuf_get_field(pbuf, qtu_macmic2_idx, qtu_macmic2) + call pbuf_get_field(pbuf, thld_macmic1_idx, thld_macmic1) + call pbuf_get_field(pbuf, thld_macmic2_idx, thld_macmic2) + call pbuf_get_field(pbuf, qtd_macmic1_idx, qtd_macmic1) + call pbuf_get_field(pbuf, qtd_macmic2_idx, qtd_macmic2) + call pbuf_get_field(pbuf, dthl_macmic1_idx, dthl_macmic1) + call pbuf_get_field(pbuf, dthl_macmic2_idx, dthl_macmic2) + call pbuf_get_field(pbuf, dqt_macmic1_idx, dqt_macmic1) + call pbuf_get_field(pbuf, dqt_macmic2_idx, dqt_macmic2) + call pbuf_get_field(pbuf, dthlu_macmic1_idx, dthlu_macmic1) + call pbuf_get_field(pbuf, dthlu_macmic2_idx, dthlu_macmic2) + call pbuf_get_field(pbuf, dqtu_macmic1_idx, dqtu_macmic1) + call pbuf_get_field(pbuf, dqtu_macmic2_idx, dqtu_macmic2) + call pbuf_get_field(pbuf, dthld_macmic1_idx, dthld_macmic1) + call pbuf_get_field(pbuf, dthld_macmic2_idx, dthld_macmic2) + call pbuf_get_field(pbuf, dqtd_macmic1_idx, dqtd_macmic1) + call pbuf_get_field(pbuf, dqtd_macmic2_idx, dqtd_macmic2) + call pbuf_get_field(pbuf, ztop_macmic1_idx, ztop_macmic1) + call pbuf_get_field(pbuf, ztop_macmic2_idx, ztop_macmic2) + call pbuf_get_field(pbuf, ddcp_macmic1_idx, ddcp_macmic1) + call pbuf_get_field(pbuf, ddcp_macmic2_idx, ddcp_macmic2) + end if + ! SILHS covariance contributions call pbuf_get_field(pbuf, rtp2_mc_zt_idx, rtp2_mc_zt) call pbuf_get_field(pbuf, thlp2_mc_zt_idx, thlp2_mc_zt) @@ -2772,6 +3337,31 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & pdf_implicit_coefs_terms_chnk(lchnk) ) end if + if (do_clubb_mf) then + ! SVP + do k = 1, pver + call qsat(state%t(1:ncol,k), state%pmid(1:ncol,k), esat(1:ncol,k), rh(1:ncol,k), ncol) + end do + + rhlev(:ncol) = 0._r8 + if (clubb_mf_Lopt==7 .or. clubb_mf_Lopt==6) then + ! Interpolate RH to 500 hPa + rh(:ncol,:) = state%q(:ncol,:,1)/rh(:ncol,:) + call vertinterp(ncol, ncol, pver, state%pmid(:ncol,:), 50000._r8, rh, rhlev, & + extrapolate='Z', ln_interp=.true., ps=state%ps(:ncol), phis=state%phis(:ncol), tbot=state%t(:ncol,pver)) + else if (clubb_mf_Lopt==8) then + ! Mass of q, by layer and vertically integrated + mq(:ncol,:) = state%q(:ncol,:,1) * state%pdel(:ncol,:) * rga + mqsat(:ncol,:) = rh(:ncol,:) * state%pdel(:ncol,:) * rga + do k=2,pver + mq(:ncol,1) = mq(:ncol,1) + mq(:ncol,k) + mqsat(:ncol,1) = mqsat(:ncol,1) + mqsat(:ncol,k) + end do + rhlev(:ncol) = mq(:ncol,1)/mqsat(:ncol,1) + end if + ! + end if + !--------------------- Scalar Setting -------------------- dl_rad = clubb_detliq_rad @@ -2996,6 +3586,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & cloud_cover_out(i,k) = 0._r8 khzm_out(i,k) = 0._r8 khzt_out(i,k) = 0._r8 + Lscale_out(i,k) = 0._r8 end do end do @@ -3087,35 +3678,178 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & end do end if + if (macmic_it==1) thlm_macmic1(:ncol,:) = 0._r8 + if (macmic_it==1) thlm_macmic2(:ncol,:) = 0._r8 + if (macmic_it==1) qtm_macmic1(:ncol,:) = 0._r8 + if (macmic_it==1) qtm_macmic2(:ncol,:) = 0._r8 + + if (do_clubb_mf) then + mf_L0 = 0._r8 + mf_L0_nadv = 0._r8 + mf_ztop = 0._r8 + mf_ztop_nadv = 0._r8 + mf_ztopm1 = 0._r8 + mf_ztopm1_nadv = 0._r8 + mf_ddcp_nadv = 0._r8 + mf_cbm1 = 0._r8 + mf_cbm1_nadv = 0._r8 + mf_freq_nadv = 0._r8 + + if (macmic_it==1) then + ztopm1_macmic(:ncol,:) = 0._r8 + ddcp_macmic(:ncol,:) = 0._r8 + cbm1_macmic(:ncol) = 0._r8 + + up_macmic1(:ncol,:) = 0._r8 + up_macmic2(:ncol,:) = 0._r8 + dn_macmic1(:ncol,:) = 0._r8 + dn_macmic2(:ncol,:) = 0._r8 + upa_macmic1(:ncol,:) = 0._r8 + upa_macmic2(:ncol,:) = 0._r8 + dna_macmic1(:ncol,:) = 0._r8 + dna_macmic2(:ncol,:) = 0._r8 + thlu_macmic1(:ncol,:) = 0._r8 + thlu_macmic2(:ncol,:) = 0._r8 + qtu_macmic1(:ncol,:) = 0._r8 + qtu_macmic2(:ncol,:) = 0._r8 + thld_macmic1(:ncol,:) = 0._r8 + thld_macmic2(:ncol,:) = 0._r8 + qtd_macmic1(:ncol,:) = 0._r8 + qtd_macmic2(:ncol,:) = 0._r8 + dthl_macmic1(:ncol,:) = 0._r8 + dthl_macmic2(:ncol,:) = 0._r8 + dqt_macmic1(:ncol,:) = 0._r8 + dqt_macmic2(:ncol,:) = 0._r8 + dthlu_macmic1(:ncol,:) = 0._r8 + dthlu_macmic2(:ncol,:) = 0._r8 + dqtu_macmic1(:ncol,:) = 0._r8 + dqtu_macmic2(:ncol,:) = 0._r8 + dthld_macmic1(:ncol,:) = 0._r8 + dthld_macmic2(:ncol,:) = 0._r8 + dqtd_macmic1(:ncol,:) = 0._r8 + dqtd_macmic2(:ncol,:) = 0._r8 + ztop_macmic1(:ncol,:) = 0._r8 + ztop_macmic2(:ncol,:) = 0._r8 + ddcp_macmic1(:ncol,:) = 0._r8 + ddcp_macmic2(:ncol,:) = 0._r8 + end if + +!+++ARH - Temporary hack - pbuf_set_field is apparently not taking? + if (is_first_step() .and. macmic_it==1) then + ddcp(:ncol,:) = 0._r8 + end if + + mf_precc_nadv(:ncol) = 0._r8 + mf_snow_nadv(:ncol) = 0._r8 + + mf_qc(:ncol,:pverp) = 0._r8 + mf_rcm(:ncol,:pverp) = 0._r8 + mf_cloudfrac(:ncol,:pverp) = 0._r8 + mf_qc_nadv(:ncol,:pverp) = 0._r8 + mf_rcm_nadv(:ncol,:pverp) = 0._r8 + mf_cloudfrac_nadv(:ncol,:pverp) = 0._r8 + + mf_thlforcup_nadv(:ncol,:pverp) = 0._r8 + mf_qtforcup_nadv(:ncol,:pverp) = 0._r8 + mf_thlforcdn_nadv(:ncol,:pverp) = 0._r8 + mf_qtforcdn_nadv(:ncol,:pverp) = 0._r8 + mf_thlforc_nadv(:ncol,:pverp) = 0._r8 + mf_qtforc_nadv(:ncol,:pverp) = 0._r8 + mf_ent_nadv(:ncol,:pverp) = 0._r8 + + max_cfl_nadv(:ncol) = 0._r8 + end if + ! Initialize EDMF outputs if (do_clubb_mf) then - do k = 1, pverp - do i = 1, pcols - mf_dry_a_output(i,k) = 0._r8 - mf_moist_a_output(i,k) = 0._r8 - mf_dry_w_output(i,k) = 0._r8 - mf_moist_w_output(i,k) = 0._r8 - mf_dry_qt_output(i,k) = 0._r8 - mf_moist_qt_output(i,k) = 0._r8 - mf_dry_thl_output(i,k) = 0._r8 - mf_moist_thl_output(i,k) = 0._r8 - mf_dry_u_output(i,k) = 0._r8 - mf_moist_u_output(i,k) = 0._r8 - mf_dry_v_output(i,k) = 0._r8 - mf_moist_v_output(i,k) = 0._r8 - mf_moist_qc_output(i,k) = 0._r8 - s_ae_output(i,k) = 0._r8 - s_aw_output(i,k) = 0._r8 - s_awthl_output(i,k) = 0._r8 - s_awqt_output(i,k) = 0._r8 - s_awql_output(i,k) = 0._r8 - s_awqi_output(i,k) = 0._r8 - s_awu_output(i,k) = 0._r8 - s_awv_output(i,k) = 0._r8 - mf_thlflx_output(i,k) = 0._r8 - mf_qtflx_output(i,k) = 0._r8 - end do - end do + mf_dry_a_output(:,:) = 0._r8 + mf_moist_a_output(:,:) = 0._r8 + mf_dry_w_output(:,:) = 0._r8 + mf_moist_w_output(:,:) = 0._r8 + mf_dry_qt_output(:,:) = 0._r8 + mf_moist_qt_output(:,:) = 0._r8 + mf_dry_thl_output(:,:) = 0._r8 + mf_moist_thl_output(:,:) = 0._r8 + mf_dry_u_output(:,:) = 0._r8 + mf_moist_u_output(:,:) = 0._r8 + mf_dry_v_output(:,:) = 0._r8 + mf_moist_v_output(:,:) = 0._r8 + mf_moist_qc_output(:,:) = 0._r8 + mf_precc_output(:,:) = 0._r8 + s_ae_output(:,:) = 0._r8 + s_aw_output(:,:) = 0._r8 + s_awthlup_output(:,:) = 0._r8 + s_awqtup_output(:,:) = 0._r8 + s_awthldn_output(:,:) = 0._r8 + s_awqtdn_output(:,:) = 0._r8 + s_awthl_output(:,:) = 0._r8 + s_awqt_output(:,:) = 0._r8 + s_awuup_output(:,:) = 0._r8 + s_awvup_output(:,:) = 0._r8 + s_awudn_output(:,:) = 0._r8 + s_awvdn_output(:,:) = 0._r8 + s_awu_output(:,:) = 0._r8 + s_awv_output(:,:) = 0._r8 + s_aww_output(:,:) = 0._r8 + mf_upa_output(:,:) = 0._r8 + mf_upw_output(:,:) = 0._r8 + mf_upmf_output(:,:) = 0._r8 + mf_upqt_output(:,:) = 0._r8 + mf_upthl_output(:,:) = 0._r8 + mf_upthv_output(:,:) = 0._r8 + mf_upth_output(:,:) = 0._r8 + mf_upqc_output(:,:) = 0._r8 + mf_upbuoy_output(:,:) = 0._r8 + mf_upent_output(:,:) = 0._r8 + mf_updet_output(:,:) = 0._r8 + mf_upa_flip(:,:,:) = 0._r8 + mf_upw_flip(:,:,:) = 0._r8 + mf_upmf_flip(:,:,:) = 0._r8 + mf_upqt_flip(:,:,:) = 0._r8 + mf_upthl_flip(:,:,:) = 0._r8 + mf_upthv_flip(:,:,:) = 0._r8 + mf_upth_flip(:,:,:) = 0._r8 + mf_upqc_flip(:,:,:) = 0._r8 + mf_upbuoy_flip(:,:,:) = 0._r8 + mf_upent_flip(:,:,:) = 0._r8 + mf_updet_flip(:,:,:) = 0._r8 + mf_thlflxup_output(:,:) = 0._r8 + mf_qtflxup_output(:,:) = 0._r8 + mf_thlflxdn_output(:,:) = 0._r8 + mf_qtflxdn_output(:,:) = 0._r8 + mf_thlflx_output(:,:) = 0._r8 + mf_qtflx_output(:,:) = 0._r8 + mf_thvflx_output(:,:) = 0._r8 + mf_uflxup_output(:,:) = 0._r8 + mf_vflxup_output(:,:) = 0._r8 + mf_uflxdn_output(:,:) = 0._r8 + mf_vflxdn_output(:,:) = 0._r8 + mf_uflx_output(:,:) = 0._r8 + mf_vflx_output(:,:) = 0._r8 + mf_thlforcup_output(:,:) = 0._r8 + mf_qtforcup_output(:,:) = 0._r8 + mf_thlforcdn_output(:,:) = 0._r8 + mf_qtforcdn_output(:,:) = 0._r8 + mf_thlforc_output(:,:) = 0._r8 + mf_qtforc_output(:,:) = 0._r8 + mf_sqtup_output(:,:) = 0._r8 + mf_sqtdn_output(:,:) = 0._r8 + mf_rcm_output(:,:) = 0._r8 + mf_cloudfrac_output(:,:) = 0._r8 + mf_ent_output(:,:) = 0._r8 + mf_qc_output(:,:) = 0._r8 + mf_ztop_output(:) = 0._r8 + mf_ddcp_output(:) = 0._r8 + mf_L0_output(:) = 0._r8 + mf_freq_output(:) = 0._r8 + mf_cape_output(:) = 0._r8 + mf_cfl_output(:) = 0._r8 + mf_dnw_output(:,:) = 0._r8 + mf_dnthl_output(:,:) = 0._r8 + mf_dnqt_output(:,:) = 0._r8 + mf_dnw_flip(:,:,:) = 0._r8 + mf_dnthl_flip(:,:,:) = 0._r8 + mf_dnqt_flip(:,:,:) = 0._r8 end if if (clubb_do_icesuper) then @@ -3533,6 +4267,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & wpthlp_in(i,k) = wpthlp(i,pverp-k+1) rtpthlp_in(i,k) = rtpthlp(i,pverp-k+1) cloud_frac_inout(i,k) = cloud_frac(i,pverp-k+1) + tke_in(i,k) = tke(i,pverp-k+1) if (k>1) then rcm_inout(i,k) = state1%q(i,pverp-k+1,ixcldliq) end if @@ -3583,10 +4318,18 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! pressure,exner on momentum grid needed for mass flux calc. if (do_clubb_mf) then + kappa_zt(:,:) = 0._r8 + qc_zt(:,:) = 0._r8 + qv_zt(:,:) = 0._r8 + th_zt(:,:) = 0._r8 + invrs_exner_zt(:,:) = 0._r8 + do k=1,pver do i=1,ncol kappa_zt(i,k+1) = (rairv(i,pver-k+1,lchnk)/cpairv(i,pver-k+1,lchnk)) qc_zt(i,k+1) = state1%q(i,pver-k+1,ixcldliq) + qv_zt(i,k+1) = state1%q(i,pver-k+1,ixq) + th_zt(i,k+1) = state1%t(i,pver-k+1)*inv_exner_clubb(i,pver-k+1) invrs_exner_zt(i,k+1) = inv_exner_clubb(i,pver-k+1) end do end do @@ -3594,11 +4337,16 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & do i=1,ncol kappa_zt(i,1) = kappa_zt(i,2) qc_zt(i,1) = qc_zt(i,2) + qv_zt(i,1) = qv_zt(i,2) + th_zt(i,1) = th_zt(i,2) invrs_exner_zt(i,1) = invrs_exner_zt(i,2) end do - kappa_zm(1:ncol,:) = zt2zm_api(nzm_clubb, ncol, gr, kappa_zt(1:ncol,:)) + kappa_zm(:,:) = 0._r8 + kappa_zm(1:ncol,:) = zt2zm_api(pverp+1-top_lev, ncol, gr, kappa_zt(1:ncol,:)) + p_in_Pa_zm(:,:) = 0._r8 + invrs_exner_zm(:,:) = 0._r8 do k=1,pverp do i=1,ncol p_in_Pa_zm(i,k) = state1%pint(i,pverp-k+1) @@ -3606,6 +4354,13 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & end do end do + th_sfc(:) = 0._r8 + th_sfc(1:ncol) = cam_in%ts(1:ncol)*invrs_exner_zm(1:ncol,1) + + !call calc_ustar( ncol, state1%t(:ncol,pver), state1%pmid(:ncol,pver), cam_in%wsx(:ncol), cam_in%wsy(:ncol), & + ! rrho(:ncol), ustar2(:ncol) ) + ustar2(1:ncol) = calc_friction_velocity(cam_in%wsx(1:ncol), cam_in%wsy(1:ncol), rrho(1:ncol)) + end if if (clubb_do_adv) then @@ -3689,6 +4444,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & if (do_clubb_mf) then call t_startf('clubb_tend_cam:do_clubb_mf') + dzt(:,:) = 0._r8 do k=2,pverp do i=1, ncol dzt(i,k) = zi_g(i,k) - zi_g(i,k-1) @@ -3700,44 +4456,413 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & invrs_dzt(i,:) = 1._r8/dzt(i,:) end do - rtm_zm_in(1:ncol,:) = zt2zm_api( nzm_clubb, ncol, gr, rtm_in(1:ncol,:) ) - thlm_zm_in(1:ncol,:) = zt2zm_api( nzm_clubb, ncol, gr, thlm_in(1:ncol,:) ) + rtm_zm_in(:,:) = 0._r8 + thlm_zm_in(:,:) = 0._r8 + th_zm(:,:) = 0._r8 + qv_zm(:,:) = 0._r8 + qc_zm(:,:) = 0._r8 + + rtm_zm_in(1:ncol,:) = zt2zm_api( pverp+1-top_lev, ncol, gr, rtm_in(1:ncol,:) ) + thlm_zm_in(1:ncol,:) = zt2zm_api( pverp+1-top_lev, ncol, gr, thlm_in(1:ncol,:) ) + th_zm(1:ncol,:) = zt2zm_api( pverp+1-top_lev, ncol, gr, th_zt(1:ncol,:) ) + qv_zm(1:ncol,:) = zt2zm_api( pverp+1-top_lev, ncol, gr, qv_zt(1:ncol,:) ) + qc_zm(1:ncol,:) = zt2zm_api( pverp+1-top_lev, ncol, gr, qc_zt(1:ncol,:) ) + + if (t>1) then + ! update thv if clubb is subcycled + do i=1, ncol + thv_ds_zt(i,:pverp) = thlm_in(i,:pverp) & + + latvap*rcm_inout(i,:pverp)*invrs_exner_zt(i,:pverp)/cpair + thv_ds_zt(i,:pverp) = thv_ds_zt(i,:pverp) & + * (1._r8+zvir*(rtm_in(i,:pverp)-rcm_inout(i,:pverp)) - rcm_inout(i,:pverp)) + end do + thv_ds_zm(1:ncol,:) = zt2zm_api( pverp+1-top_lev, ncol, gr, thv_ds_zt(1:ncol,:) ) + end if + + mf_ztopm1(1:ncol,:) = ztopma(1:ncol,:) + mf_ddcp(1:ncol,:) = ddcp(1:ncol,:) + mf_cbm1(1:ncol) = cbm1(1:ncol) + rhinv(1:ncol) = 0._r8 do i=1, ncol - call integrate_mf( pverp, dzt(i,:), zi_g(i,:), p_in_Pa_zm(i,:), invrs_exner_zm(i,:), & ! input - p_in_Pa(i,:), invrs_exner_zt(i,:), & ! input - um_in(i,:), vm_in(i,:), thlm_in(i,:), rtm_in(i,:), thv(i,:), & ! input - thlm_zm_in(i,:), rtm_zm_in(i,:), & ! input - wpthlp_sfc(i), wprtp_sfc(i), pblh(i), & ! input - mf_dry_a(i,:), mf_moist_a(i,:), & ! output - plume diagnostics - mf_dry_w(i,:), mf_moist_w(i,:), & ! output - plume diagnostics - mf_dry_qt(i,:), mf_moist_qt(i,:), & ! output - plume diagnostics - mf_dry_thl(i,:), mf_moist_thl(i,:), & ! output - plume diagnostics - mf_dry_u(i,:), mf_moist_u(i,:), & ! output - plume diagnostics - mf_dry_v(i,:), mf_moist_v(i,:), & ! output - plume diagnostics - mf_moist_qc(i,:), & ! output - plume diagnostics - s_ae(i,:), s_aw(i,:), & ! output - plume diagnostics - s_awthl(i,:), s_awqt(i,:), & ! output - plume diagnostics - s_awql(i,:), s_awqi(i,:), & ! output - plume diagnostics - s_awu(i,:), s_awv(i,:), & ! output - plume diagnostics - mf_thlflx(i,:), mf_qtflx(i,:) ) ! output - variables needed for solver + if (rhlev(i) >= 1._r8) rhlev(i) = 0.990_r8 + if (rhlev(i) > 0._r8) rhinv(i) = 1._r8 / ( (1._r8/rhlev(i)) - 1._r8 ) end do - ! pass MF turbulent advection term as CLUBB explicit forcing term do i=1, ncol - rtm_forcing(i,1) = 0._r8 - thlm_forcing(i,1)= 0._r8 + ! invert index of tropopause + trop_mf = pverp - troplev(i) + 1 + + call integrate_mf( pverp, & ! input + rho_zm(i,:), dzm(i,:), zi_g(i,:), p_in_Pa_zm(i,:), invrs_exner_zm(i,:), & ! input + rho_zt(i,:), dzt(i,:), zt_g(i,:), p_in_Pa(i,:), invrs_exner_zt(i,:), & ! input + um_in(i,:), vm_in(i,:), thlm_in(i,:), rtm_in(i,:), thv_ds_zt(i,:), & ! input + trop_mf, wm_zm(i,:), th_zt(i,:), qv_zt(i,:), qc_zt(i,:), & ! input + thlm_zm_in(i,:), rtm_zm_in(i,:), thv_ds_zm(i,:), & ! input + th_zm(i,:), qv_zm(i,:), qc_zm(i,:), & ! input + ustar2(i), th_sfc(i), wpthlp_sfc(i), wprtp_sfc(i), pblh(i), & ! input + wpthlp_in(i,:), tke_in(i,:), tpert(i), mf_ztopm1(i,:), rhinv(i), & ! input + wpthvp_in(i,:), wprtp_in(i,:), mf_cape_output(i),mf_ddcp(i,:), mf_cbm1(i), & ! output - plume diagnostics + mf_upa(i,:,:), mf_dna(i,:,:), & ! output - plume diagnostics + mf_upw(i,:,:), mf_dnw(i,:,:), & ! output - plume diagnostics + mf_upmf(i,:,:), & ! output - plume diagnostics + mf_upqt(i,:,:), mf_dnqt(i,:,:), & ! output - plume diagnostics + mf_upthl(i,:,:), mf_dnthl(i,:,:), & ! output - plume diagnostics + mf_upthv(i,:,:), mf_dnthv(i,:,:), & ! output - plume diagnostics + mf_upth(i,:,:), mf_dnth(i,:,:), & ! output - plume diagnostics + mf_upqc(i,:,:), mf_dnqc(i,:,:), & ! output - plume diagnostics + mf_upbuoy(i,:,:), & ! output - plume diagnostics + mf_upent(i,:,:), & ! output - plume diagnostics + mf_updet(i,:,:), & ! output - plume diagnostics + mf_dry_a(i,:), mf_moist_a(i,:), & ! output - plume diagnostics + mf_dry_w(i,:), mf_moist_w(i,:), & ! output - plume diagnostics + mf_dry_qt(i,:), mf_moist_qt(i,:), & ! output - plume diagnostics + mf_dry_thl(i,:), mf_moist_thl(i,:), & ! output - plume diagnostics + mf_dry_u(i,:), mf_moist_u(i,:), & ! output - plume diagnostics + mf_dry_v(i,:), mf_moist_v(i,:), & ! output - plume diagnostics + mf_moist_qc(i,:), & ! output - plume diagnostics + s_ae(i,:), & ! output - plume diagnostics + s_ac(i,:), s_aup(i,:), s_adn(i,:), & ! output - plume diagnostics + s_aw(i,:), s_awup(i,:), s_awdn(i,:), & ! output - plume diagnostics + s_aww(i,:), s_awwup(i,:), s_awwdn(i,:), & ! output - plume diagnostics + s_awthlup(i,:), s_awqtup(i,:), s_awuup(i,:), s_awvup(i,:), & ! output - plume diagnostics + s_awthldn(i,:), s_awqtdn(i,:), s_awudn(i,:), s_awvdn(i,:), & ! output - plume diagnostics + s_awthl(i,:), s_awqt(i,:), & ! output - plume diagnostics + s_awu(i,:), s_awv(i,:), & ! output - plume diagnostics + mf_thlflxup(i,:), mf_qtflxup(i,:), mf_uflxup(i,:), mf_vflxup(i,:), & ! output - plume diagnostics + mf_thlflxdn(i,:), mf_qtflxdn(i,:), mf_uflxdn(i,:), mf_vflxdn(i,:), & ! output - plume diagnostics + mf_thlflx(i,:), mf_qtflx(i,:), mf_uflx(i,:), mf_vflx(i,:), & ! output - variables needed for solver + mf_thvflx(i,:), & ! output - plume diagnostics + mf_sqtup(i,:), mf_sthlup(i,:), & ! output - plume diagnostics + mf_sqtdn(i,:), mf_sthldn(i,:), & ! output - plume diagnostics + mf_sqt(i,:), mf_sthl(i,:), & ! output - variables needed for solver + mf_precc(i,:), & ! output - plume diagnostics + mf_ztop(i,:), mf_L0(i,:) ) + end do + ! CFL limiter + cfllim = .true. + cflfac(:ncol) = 1._r8 + s_aw(:ncol,1) = 0._r8 + max_cfl(:ncol)= 0._r8 + do i=1,ncol + do k=2,pverp + max_cfl(i) = max(max_cfl(i),dtime*invrs_dzt(i,k)*max(abs(s_aw(i,k-1)),abs(s_aw(i,k)))) + end do + if (max_cfl(i).gt.cflval.and.cfllim) cflfac(i) = cflval/max_cfl(i) + end do + + ! Scale microphys so it can't drive qt negative + do k=2,pverp + do i=1,ncol + if ((-1._r8*mf_sqt(i,k)*dtime) > rtm_in(i,k)) then + lambda = -1._r8*rtm_in(i,k)/(mf_sqt(i,k)*dtime) + mf_sqt(i,k) = lambda*mf_sqt(i,k) + mf_sthl(i,k) = lambda*mf_sthl(i,k) + mf_sqtup(i,k) = lambda*mf_sqtup(i,k) + mf_sthlup(i,k) = lambda*mf_sthlup(i,k) + mf_sqtdn(i,k) = lambda*mf_sqtdn(i,k) + mf_sthldn(i,k) = lambda*mf_sthldn(i,k) + end if + end do + end do + + ! Recalculate precip using new microphys forcing + mf_precc(:ncol,:pverp) = 0._r8 + do k=pverp,2,-1 + do i=1,ncol + mf_precc(i,k-1) = mf_precc(i,k) - rho_zt(i,k)*dzt(i,k)*mf_sqt(i,k) + end do + end do + + ! pass MF turbulent advection term as CLUBB explicit forcing term + rtm_forcing(:ncol,:) = 0._r8 + thlm_forcing(:ncol,:) = 0._r8 + mf_qtforcup(:ncol,:) = 0._r8 + mf_thlforcup(:ncol,:) = 0._r8 + mf_qtforcdn(:ncol,:) = 0._r8 + mf_thlforcdn(:ncol,:) = 0._r8 + do k=2,pverp do i=1, ncol - rtm_forcing(i,k) = rtm_forcing(i,k) - invrs_rho_ds_zt(i,k) * invrs_dzt(i,k) * & - ((rho_ds_zm(i,k) * mf_qtflx(i,k)) - (rho_ds_zm(i,k-1) * mf_qtflx(i,k-1))) + rtm_forcing(i,k) = rtm_forcing(i,k) - invrs_rho_ds_zt(i,k) * invrs_dzt(i,k) * cflfac(i) * & + ((rho_ds_zm(i,k) * mf_qtflx(i,k)) - (rho_ds_zm(i,k-1) * mf_qtflx(i,k-1))) & + + mf_sqt(i,k) + + thlm_forcing(i,k) = thlm_forcing(i,k) - invrs_rho_ds_zt(i,k) * invrs_dzt(i,k) * cflfac(i) * & + ((rho_ds_zm(i,k) * mf_thlflx(i,k)) - (rho_ds_zm(i,k-1) * mf_thlflx(i,k-1))) & + + mf_sthl(i,k) + + mf_qtforcup(i,k) = mf_qtforcup(i,k) - invrs_rho_ds_zt(i,k) * invrs_dzt(i,k) * cflfac(i) * & + ((rho_ds_zm(i,k) * mf_qtflxup(i,k)) - (rho_ds_zm(i,k-1) * mf_qtflxup(i,k-1))) & + + mf_sqtup(i,k) + + mf_thlforcup(i,k) = mf_thlforcup(i,k) - invrs_rho_ds_zt(i,k) * invrs_dzt(i,k) * cflfac(i) * & + ((rho_ds_zm(i,k) * mf_thlflxup(i,k)) - (rho_ds_zm(i,k-1) * mf_thlflxup(i,k-1))) & + + mf_sthlup(i,k) + + mf_qtforcdn(i,k) = mf_qtforcdn(i,k) - invrs_rho_ds_zt(i,k) * invrs_dzt(i,k) * cflfac(i) * & + ((rho_ds_zm(i,k) * mf_qtflxdn(i,k)) - (rho_ds_zm(i,k-1) * mf_qtflxdn(i,k-1))) & + + mf_sqtdn(i,k) + + mf_thlforcdn(i,k) = mf_thlforcdn(i,k) - invrs_rho_ds_zt(i,k) * invrs_dzt(i,k) * cflfac(i) * & + ((rho_ds_zm(i,k) * mf_thlflxdn(i,k)) - (rho_ds_zm(i,k-1) * mf_thlflxdn(i,k-1))) & + + mf_sthldn(i,k) - thlm_forcing(i,k) = thlm_forcing(i,k) - invrs_rho_ds_zt(i,k) * invrs_dzt(i,k) * & - ((rho_ds_zm(i,k) * mf_thlflx(i,k)) - (rho_ds_zm(i,k-1) * mf_thlflx(i,k-1))) end do end do + + if (do_clubb_mf_cmt) then + ! convective momentum transport + um_forcing(:ncol,:) = 0._r8 + vm_forcing(:ncol,:) = 0._r8 + do k=2,pverp + do i=1, ncol + um_forcing(i,k) = um_forcing(i,k) - invrs_rho_ds_zt(i,k) * invrs_dzt(i,k) * cflfac(i) * & + ((rho_ds_zm(i,k) * mf_uflx(i,k)) - (rho_ds_zm(i,k-1) * mf_uflx(i,k-1))) + + vm_forcing(i,k) = vm_forcing(i,k) - invrs_rho_ds_zt(i,k) * invrs_dzt(i,k) * cflfac(i) * & + ((rho_ds_zm(i,k) * mf_vflx(i,k)) - (rho_ds_zm(i,k-1) * mf_vflx(i,k-1))) + end do + end do + end if + + do i=1,ncol + ! compute ensemble cloud properties + mf_qc_nadv(i,:pverp) = mf_qc_nadv(i,:pverp) + mf_moist_qc(i,:pverp) + mf_rcm_nadv(i,:pverp) = mf_rcm_nadv(i,:pverp) + mf_moist_a(i,:pverp)*mf_moist_qc(i,:pverp) + mf_cloudfrac_nadv(i,:pverp) = mf_cloudfrac_nadv(i,:pverp) + mf_moist_a(i,:pverp) + + ! [kg/m2/s]->[m/s] + mf_precc_nadv(i) = mf_precc_nadv(i) + mf_precc(i,1)/1000._r8 + mf_snow_nadv(i) = 0._r8 + + ! accumulate over nadv subcycles + mf_L0_nadv(i,:) = mf_L0_nadv(i,:) + mf_L0(i,:) + mf_ztop_nadv(i,:) = mf_ztop_nadv(i,:) + mf_ztop(i,:) + mf_ztopm1_nadv(i,:) = mf_ztopm1_nadv(i,:) + mf_ztopm1(i,:) + mf_ddcp_nadv(i,:) = mf_ddcp_nadv(i,:) + mf_ddcp(i,:) + mf_cbm1_nadv(i) = mf_cbm1_nadv(i) + mf_cbm1(i) + + if (ANY(mf_ztop(i,:) > 0._r8)) mf_freq_nadv(i) = mf_freq_nadv(i) + 1._r8 + + mf_thlforcup_nadv(i,:pverp) = mf_thlforcup_nadv(i,:pverp) + mf_thlforcup(i,:pverp) + mf_qtforcup_nadv(i,:pverp) = mf_qtforcup_nadv(i,:pverp) + mf_qtforcup(i,:pverp) + mf_thlforcdn_nadv(i,:pverp) = mf_thlforcdn_nadv(i,:pverp) + mf_thlforcdn(i,:pverp) + mf_qtforcdn_nadv(i,:pverp) = mf_qtforcdn_nadv(i,:pverp) + mf_qtforcdn(i,:pverp) + mf_thlforc_nadv(i,:pverp) = mf_thlforc_nadv(i,:pverp) + thlm_forcing(i,:pverp) + mf_qtforc_nadv(i,:pverp) = mf_qtforc_nadv(i,:pverp) + rtm_forcing(i,:pverp) + + mf_ent_nadv(i,:pverp) = mf_ent_nadv(i,:pverp) + s_awu(i,:pverp) + + max_cfl_nadv(i) = MAX(max_cfl(i),max_cfl_nadv(i)) + end do + + if (t==1) then + + do i=1,ncol + ztop_macmic1(i,macmic_it) = MAXVAL(mf_ztopm1(i,:)) + ddcp_macmic1(i,macmic_it) = MAXVAL(mf_ddcp(i,:)) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_upw(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + up_macmic1(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_dnw(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + dn_macmic1(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_upa(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + upa_macmic1(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_dna(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + dna_macmic1(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_upthl(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + thlu_macmic1(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_upqt(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + qtu_macmic1(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_dnthl(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + thld_macmic1(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_dnqt(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + qtd_macmic1(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = thlm_forcing(:ncol,k) + end do + dthl_macmic1(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = rtm_forcing(:ncol,k) + end do + dqt_macmic1(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = mf_thlforcup(:ncol,k) + end do + dthlu_macmic1(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = mf_qtforcup(:ncol,k) + end do + dqtu_macmic1(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = mf_thlforcdn(:ncol,k) + end do + dthld_macmic1(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = mf_qtforcdn(:ncol,k) + end do + dqtd_macmic1(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + else if (t==2) then + + do i=1,ncol + ztop_macmic2(i,macmic_it) = MAXVAL(mf_ztopm1(i,:)) + ddcp_macmic2(i,macmic_it) = MAXVAL(mf_ddcp(i,:)) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_upw(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + up_macmic2(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_dnw(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + dn_macmic2(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_upa(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + upa_macmic2(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_dna(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + dna_macmic2(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_upthl(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + thlu_macmic2(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_upqt(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + qtu_macmic2(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_dnthl(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + thld_macmic2(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + flip(:ncol,pverp-k+1,:clubb_mf_nup) = mf_dnqt(:ncol,k,:clubb_mf_nup) + end do + + do k=1,clubb_mf_nup + qtd_macmic2(:ncol, 1+pverp*(clubb_mf_nup*(macmic_it-1)+k-1):pverp*(clubb_mf_nup*(macmic_it-1)+k) ) = flip(:ncol,:pverp,k) + end do + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = thlm_forcing(:ncol,k) + end do + dthl_macmic2(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = rtm_forcing(:ncol,k) + end do + dqt_macmic2(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = mf_thlforcup(:ncol,k) + end do + dthlu_macmic2(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = mf_qtforcup(:ncol,k) + end do + dqtu_macmic2(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = mf_thlforcdn(:ncol,k) + end do + dthld_macmic2(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = mf_qtforcdn(:ncol,k) + end do + dqtd_macmic2(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + end if + call t_stopf('clubb_tend_cam:do_clubb_mf') end if @@ -3787,7 +4912,8 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & qclvar_out, thlprcp_out, & wprcp_out, w_up_in_cloud_out, w_down_in_cloud_out, & cloudy_updraft_frac_out, cloudy_downdraft_frac_out, & - rcm_in_layer_out, cloud_cover_out, invrs_tau_zm_out ) + rcm_in_layer_out, cloud_cover_out, invrs_tau_zm_out, & + Lscale_out ) !+++arh call t_stopf('clubb_tend_cam:advance_clubb_core_api') ! Note that CLUBB does not produce an error code specific to any column, and @@ -3866,8 +4992,99 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call t_stopf('clubb_tend_cam:stats_end_timestep_clubb') end if + !substep output + if (t==1) then + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = thlm_in(:ncol,k) + end do + thlm_macmic1(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = rtm_in(:ncol,k) + end do + qtm_macmic1(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + else if (t==2) then + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = thlm_in(:ncol,k) + end do + thlm_macmic2(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + do k=1,pverp+1-top_lev + lilflip(:ncol,pverp-k+1) = rtm_in(:ncol,k) + end do + qtm_macmic2(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = lilflip(:ncol,:pverp) + + end if + + enddo ! end time loop + if (do_clubb_mf) then + ! average over nadv + mf_L0_nadv = mf_L0_nadv/REAL(nadv) + mf_ztop_nadv = mf_ztop_nadv/REAL(nadv) + mf_ztopm1_nadv = mf_ztopm1_nadv/REAL(nadv) + mf_ddcp_nadv = mf_ddcp_nadv/REAL(nadv) + mf_cbm1_nadv = mf_cbm1_nadv/REAL(nadv) + mf_freq_nadv = mf_freq_nadv/REAL(nadv) + + ! accumulate in buffer + ztopm1_macmic(:ncol,:) = ztopm1_macmic(:ncol,:) + mf_ztopm1_nadv(:ncol,:) + ddcp_macmic(:ncol,:) = ddcp_macmic(:ncol,:) + mf_ddcp_nadv(:ncol,:) + cbm1_macmic(:ncol) = cbm1_macmic(:ncol) + mf_cbm1_nadv(:ncol) + + if (macmic_it == cld_macmic_num_steps) then + + cbm1(:ncol) = cbm1_macmic(:ncol)/REAL(cld_macmic_num_steps) + + if (clubb_mf_up_ndt == 1) then + ztopma(:ncol,:) = ztopm1_macmic(:ncol,:)/REAL(cld_macmic_num_steps) + else + ztopmn(2:clubb_mf_up_ndt,:ncol,:) = ztopmn(1:clubb_mf_up_ndt-1,:ncol,:) + ztopmn(1,:ncol,:) = ztopm1_macmic(:ncol,:)/REAL(cld_macmic_num_steps) + ztopma(:ncol,:) = 0._r8 + do t=1,clubb_mf_up_ndt + ztopma(:ncol,:) = ztopma(:ncol,:) + ztopmn(t,:ncol,:) + end do + ztopma(:ncol,:) = ztopma(:ncol,:)/REAL(clubb_mf_up_ndt) + end if + + if (clubb_mf_cp_ndt == 1) then + ddcp(:ncol,:) = ddcp_macmic(:ncol,:)/REAL(cld_macmic_num_steps) + else + ddcpmn(2:clubb_mf_cp_ndt,:ncol,:) = ddcpmn(1:clubb_mf_cp_ndt-1,:ncol,:) + ddcpmn(1,:ncol,:) = ddcp_macmic(:ncol,:)/REAL(cld_macmic_num_steps) + ddcp(:ncol,:) = 0._r8 + do t=1,clubb_mf_cp_ndt + ddcp(:ncol,:) = ddcp(:ncol,:) + ddcpmn(t,:ncol,:) + end do + ddcp(:ncol,:) = ddcp(:ncol,:)/REAL(clubb_mf_cp_ndt) + end if + + ddcp(:ncol,:) = clubb_mf_ddalph*ddcp(:ncol,:) + + end if + + mf_qc(:ncol,:pverp) = mf_qc_nadv(:ncol,:pverp)/REAL(nadv) + mf_rcm(:ncol,:pverp) = mf_rcm_nadv(:ncol,:pverp)/REAL(nadv) + mf_cloudfrac(:ncol,:pverp) = mf_cloudfrac_nadv(:ncol,:pverp)/REAL(nadv) + prec_sh(:ncol) = mf_precc_nadv(:ncol)/REAL(nadv) + snow_sh(:ncol) = mf_snow_nadv(:ncol)/REAL(nadv) + + mf_thlforcup_nadv(:ncol,:pverp) = mf_thlforcup_nadv(:ncol,:pverp)/REAL(nadv) + mf_qtforcup_nadv(:ncol,:pverp) = mf_qtforcup_nadv(:ncol,:pverp)/REAL(nadv) + mf_thlforcdn_nadv(:ncol,:pverp) = mf_thlforcdn_nadv(:ncol,:pverp)/REAL(nadv) + mf_qtforcdn_nadv(:ncol,:pverp) = mf_qtforcdn_nadv(:ncol,:pverp)/REAL(nadv) + mf_thlforc_nadv(:ncol,:pverp) = mf_thlforc_nadv(:ncol,:pverp)/REAL(nadv) + mf_qtforc_nadv(:ncol,:pverp) = mf_qtforc_nadv(:ncol,:pverp)/REAL(nadv) + + mf_ent_nadv(:ncol,:pverp) = mf_ent_nadv(:ncol,:pverp)/REAL(nadv) + + end if !clubbmf + if (clubb_do_adv) then if (macmic_it == cld_macmic_num_steps) then @@ -3898,6 +5115,14 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & thl2_zt = zm2zt_api( nzm_clubb, ncol, gr, thlp2_in ) wp2_zt = zm2zt_api( nzm_clubb, ncol, gr, wp2_in ) + ! Need moist_qc and cloudfrac on thermo grid for output + mf_qc_zt(:,:) = 0._r8 + mf_cloudfrac_zt(:,:) = 0._r8 + mf_qc_zt = zm2zt_api( pverp+1-top_lev, ncol, gr, mf_qc) + mf_cloudfrac_zt = zm2zt_api( pverp+1-top_lev, ncol, gr, mf_cloudfrac) + !mf_qc_zt(1:ncol,:) = zm2zt_api( pverp+1-top_lev, ncol, gr, mf_qc(1:ncol,:)) + !mf_cloudfrac_zt(1:ncol,:) = zm2zt_api( pverp+1-top_lev, ncol, gr, mf_cloudfrac(1:ncol,:)) + call t_startf('clubb_tend_cam:flip-index') ! Arrays need to be "flipped" to CAM grid @@ -3920,7 +5145,12 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & rtm(i,pverp-k+1) = rtm_in(i,k) wprtp(i,pverp-k+1) = wprtp_in(i,k) wpthlp(i,pverp-k+1) = wpthlp_in(i,k) - wp2(i,pverp-k+1) = wp2_in(i,k) +!+++ARH This where wp2 pbuf is set + if (do_clubb_mf_addtke) then + wp2(i,pverp-k+1) = wp2_in(i,k) + s_aww(i,k) + else + wp2(i,pverp-k+1) = wp2_in(i,k) + end if wp3(i,pverp-k+1) = wp3_in(i,k) rtp2(i,pverp-k+1) = rtp2_in(i,k) thlp2(i,pverp-k+1) = thlp2_in(i,k) @@ -3939,7 +5169,11 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & cloud_cover(i,pverp-k+1) = min(cloud_cover_out(i,k),1._r8) zt_out(i,pverp-k+1) = zt_g(i,k) zi_out(i,pverp-k+1) = zi_g(i,k) - khzm(i,pverp-k+1) = khzm_out(i,k) + if (do_clubb_mf_addtke) then + khzm(i,pverp-k+1) = khzm_out(i,k) + clubb_params(i,ic_K) * Lscale_out(i,k) * (0.5_r8*s_aww(i,k))**0.5_r8 + else + khzm(i,pverp-k+1) = khzm_out(i,k) + end if qclvar(i,pverp-k+1) = min(1._r8,qclvar_out(i,k)) wm_zt_out(i,pverp-k+1) = wm_zt(i,k) wp2rtp(i,pverp-k+1) = wp2rtp_inout(i,k) @@ -3988,22 +5222,108 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & mf_dry_v_output(i,pverp-k+1) = mf_dry_v(i,k) mf_moist_v_output(i,pverp-k+1) = mf_moist_v(i,k) mf_moist_qc_output(i,pverp-k+1) = mf_moist_qc(i,k) - mf_thlflx_output(i,pverp-k+1) = mf_thlflx(i,k) - mf_qtflx_output(i,pverp-k+1) = mf_qtflx(i,k) + s_ae_output(i,pverp-k+1) = s_ae(i,k) s_aw_output(i,pverp-k+1) = s_aw(i,k) + + s_awthlup_output(i,pverp-k+1) = s_awthlup(i,k) + s_awqtup_output(i,pverp-k+1) = s_awqtup(i,k) + s_awthldn_output(i,pverp-k+1) = s_awthldn(i,k) + s_awqtdn_output(i,pverp-k+1) = s_awqtdn(i,k) s_awthl_output(i,pverp-k+1) = s_awthl(i,k) s_awqt_output(i,pverp-k+1) = s_awqt(i,k) - s_awql_output(i,pverp-k+1) = s_awql(i,k) - s_awqi_output(i,pverp-k+1) = s_awqi(i,k) + + s_awuup_output(i,pverp-k+1) = s_awuup(i,k) + s_awvup_output(i,pverp-k+1) = s_awvup(i,k) + s_awudn_output(i,pverp-k+1) = s_awudn(i,k) + s_awvdn_output(i,pverp-k+1) = s_awvdn(i,k) + s_awu_output(i,pverp-k+1) = s_awu(i,k) s_awv_output(i,pverp-k+1) = s_awv(i,k) + s_aww_output(i,pverp-k+1) = s_aww(i,k) + + mf_thlflxup_output(i,pverp-k+1) = mf_thlflxup(i,k) + mf_qtflxup_output(i,pverp-k+1) = mf_qtflxup(i,k) + mf_thlflxdn_output(i,pverp-k+1) = mf_thlflxdn(i,k) + mf_qtflxdn_output(i,pverp-k+1) = mf_qtflxdn(i,k) mf_thlflx_output(i,pverp-k+1) = mf_thlflx(i,k) mf_qtflx_output(i,pverp-k+1) = mf_qtflx(i,k) + mf_thvflx_output(i,pverp-k+1) = mf_thvflx(i,k) + + mf_uflxup_output(i,pverp-k+1) = mf_uflxup(i,k) + mf_vflxup_output(i,pverp-k+1) = mf_vflxup(i,k) + mf_uflxdn_output(i,pverp-k+1) = mf_uflxdn(i,k) + mf_vflxdn_output(i,pverp-k+1) = mf_vflxdn(i,k) + mf_uflx_output(i,pverp-k+1) = mf_uflx(i,k) + mf_vflx_output(i,pverp-k+1) = mf_vflx(i,k) + + if (k.ne.1) then + mf_thlforcup_output(i,pverp-k+1) = mf_thlforcup_nadv(i,k) + mf_qtforcup_output(i,pverp-k+1) = mf_qtforcup_nadv(i,k) + mf_thlforcdn_output(i,pverp-k+1) = mf_thlforcdn_nadv(i,k) + mf_qtforcdn_output(i,pverp-k+1) = mf_qtforcdn_nadv(i,k) + mf_thlforc_output(i,pverp-k+1) = mf_thlforc_nadv(i,k) + mf_qtforc_output(i,pverp-k+1) = mf_qtforc_nadv(i,k) + mf_sqtup_output(i,pverp-k+1) = mf_sqtup(i,k) + mf_sqtdn_output(i,pverp-k+1) = mf_sqtdn(i,k) + + mf_cloudfrac_output(i,pverp-k+1) = mf_cloudfrac_zt(i,k) + mf_ent_output(i,pverp-k+1) = mf_ent_nadv(i,k) + mf_qc_output(i,pverp-k+1) = mf_qc_zt(i,k) + end if + + mf_upa_flip(i,pverp-k+1,:clubb_mf_nup) = mf_upa(i,k,:clubb_mf_nup) + mf_upw_flip(i,pverp-k+1,:clubb_mf_nup) = mf_upw(i,k,:clubb_mf_nup) + mf_upmf_flip(i,pverp-k+1,:clubb_mf_nup) = mf_upmf(i,k,:clubb_mf_nup) + mf_upqt_flip(i,pverp-k+1,:clubb_mf_nup) = mf_upqt(i,k,:clubb_mf_nup) + mf_upthl_flip(i,pverp-k+1,:clubb_mf_nup) = mf_upthl(i,k,:clubb_mf_nup) + mf_upthv_flip(i,pverp-k+1,:clubb_mf_nup) = mf_upthv(i,k,:clubb_mf_nup) + mf_upth_flip(i,pverp-k+1,:clubb_mf_nup) = mf_upth(i,k,:clubb_mf_nup) + mf_upqc_flip(i,pverp-k+1,:clubb_mf_nup) = mf_upqc(i,k,:clubb_mf_nup) + mf_upent_flip(i,pverp-k+1,:clubb_mf_nup) = mf_upent(i,k,:clubb_mf_nup) + mf_updet_flip(i,pverp-k+1,:clubb_mf_nup) = mf_updet(i,k,:clubb_mf_nup) + mf_upbuoy_flip(i,pverp-k+1,:clubb_mf_nup) = mf_upbuoy(i,k,:clubb_mf_nup) + mf_dnw_flip(i,pverp-k+1,:clubb_mf_nup) = mf_dnw(i,k,:clubb_mf_nup) + mf_dnthl_flip(i,pverp-k+1,:clubb_mf_nup) = mf_dnthl(i,k,:clubb_mf_nup) + mf_dnqt_flip(i,pverp-k+1,:clubb_mf_nup) = mf_dnqt(i,k,:clubb_mf_nup) end do end do end if + if (do_clubb_mf) then + ! these fillvalues won't average correctly + !if (mf_ztop_nadv == 0._r8) mf_ztop_nadv = fillvalue + !if (mf_L0_nadv == 0._r8) mf_L0_nadv = fillvalue + + do i=1,ncol + mf_ztop_output(i) = MAXVAL(ztopma(i,:)) + !mf_ztop_output(i) = MAXVAL(mf_ztop_nadv(i,:)) + mf_ddcp_output(i) = MAXVAL(ddcp(i,:)) + !mf_ddcp_output(i) = MAXVAL(mf_ddcp_nadv(i,:)) + mf_L0_output(i) = MAXVAL(mf_L0_nadv(i,:)) + end do + + mf_cfl_output(:ncol) = max_cfl_nadv(:ncol) + mf_freq_output(:ncol) = mf_freq_nadv(:ncol) + + do k=1,clubb_mf_nup + mf_upa_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_upa_flip(:ncol,:pverp,k) + mf_upw_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_upw_flip(:ncol,:pverp,k) + mf_upmf_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_upmf_flip(:ncol,:pverp,k) + mf_upqt_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_upqt_flip(:ncol,:pverp,k) + mf_upthl_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_upthl_flip(:ncol,:pverp,k) + mf_upthv_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_upthv_flip(:ncol,:pverp,k) + mf_upth_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_upth_flip(:ncol,:pverp,k) + mf_upqc_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_upqc_flip(:ncol,:pverp,k) + mf_upent_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_upent_flip(:ncol,:pverp,k) + mf_updet_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_updet_flip(:ncol,:pverp,k) + mf_upbuoy_output(:ncol,pverp*(k-1)+1:pverp*k)= mf_upbuoy_flip(:ncol,:pverp,k) + mf_dnw_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_dnw_flip(:ncol,:pverp,k) + mf_dnthl_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_dnthl_flip(:ncol,:pverp,k) + mf_dnqt_output(:ncol,pverp*(k-1)+1:pverp*k) = mf_dnqt_flip(:ncol,:pverp,k) + end do + end if !clubbmf + !$acc parallel loop gang vector collapse(2) default(present) do k=1, nzm_clubb do i=1, ncol @@ -4150,6 +5470,9 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! Use correct qflux from cam_in, not lhf/latvap as was done previously te_b = te_b + (cam_in%shf(i)+cam_in%cflx(i,1)*(latvap+latice)) * hdtime + ! subtract enthalpy of falling precip from tb + te_b = te_b - prec_sh(i)*1000._r8*latice*hdtime + ! Compute the disbalance of total energy, over depth where CLUBB is active se_dis(i) = ( te_a - te_b ) / ( state1%pint(i,pverp) - state1%pint(i,clubbtop(i)) ) @@ -4550,10 +5873,22 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & if (do_clubb_mf) then mf_thlflx_output(i,k) = mf_thlflx_output(i,k)*rho(i,k)*cpair mf_qtflx_output(i,k) = mf_qtflx_output(i,k)*rho(i,k)*latvap + mf_precc_output(i,k) = mf_precc_output(i,k)/rhoh2o end if enddo enddo + rcm_macmic(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = rcm(:ncol,:pverp) + cldfrac_macmic(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = cloud_frac(:ncol,:pverp) + wpthlp_macmic(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = wpthlp_output(:ncol,:pverp) + wprtp_macmic(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = wprtp_output(:ncol,:pverp) + wpthvp_macmic(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = wpthvp(:ncol,:pverp) + if (do_clubb_mf) then + mf_thlflx_macmic(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = mf_thlflx_output(:ncol,:pverp) + mf_qtflx_macmic(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = mf_qtflx_output(:ncol,:pverp) + mf_thvflx_macmic(:ncol,pverp*(macmic_it-1)+1:pverp*macmic_it) = mf_thvflx_output(:ncol,:pverp) + end if + ! --------------------------------------------------------------------------------- ! ! Diagnose some quantities that are computed in macrop_tend here. ! ! These are inputs required for the microphysics calculation. ! @@ -4578,6 +5913,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & deepcu(:,:) = 0.0_r8 shalcu(:,:) = 0.0_r8 + sh_icwmr(:,:) = 0.0_r8 do k=1,pver-1 do i=1,ncol @@ -4586,17 +5922,27 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! called, the shallow convective mass flux will ALWAYS be zero, ensuring that this cloud ! fraction is purely from deep convection scheme. deepcu(i,k) = max(0.0_r8,min(dp1*log(1.0_r8+dp2*(cmfmc(i,k+1)-cmfmc_sh(i,k+1))),0.6_r8)) - shalcu(i,k) = 0._r8 if (deepcu(i,k) <= frac_limit .or. dp_icwmr(i,k) < ic_limit) then deepcu(i,k) = 0._r8 endif - ! using the deep convective cloud fraction, and CLUBB cloud fraction (variable - ! "cloud_frac"), compute the convective cloud fraction. This follows the formulation - ! found in macrophysics code. Assumes that convective cloud is all nonstratiform cloud - ! from CLUBB plus the deep convective cloud fraction - concld(i,k) = min(cloud_frac(i,k)-alst(i,k)+deepcu(i,k),0.80_r8) + ! While shallow convection is never called, CLUBB+MF uses the shallow cloud fraction and + ! shallow in-cloud mixing ratio pbuf variables to couple with radiation. + if (do_clubb_mf_rad) then + shalcu(i,k) = clubb_mf_cldfrac_fac*mf_cloudfrac_output(i,k) + sh_icwmr(i,k) = mf_qc_output(i,k) + end if + + if (shalcu(i,k) <= frac_limit .or. sh_icwmr(i,k) < ic_limit) then + shalcu(i,k) = 0._r8 + endif + + ! using the deep convective cloud fraction, CLUBB cloud fraction (variable + ! "cloud_frac") and CLUBB+MF cloud fraction ("shalcu") compute the convective cloud + ! fraction. This follows the formulation found in macrophysics code. Assumes that convective + ! cloud is all nonstratiform cloud from CLUBB or CLUBB+MF plus the deep convective cloud fraction + concld(i,k) = min(cloud_frac(i,k)-alst(i,k)+deepcu(i,k)+shalcu(i,k),0.80_r8) enddo enddo @@ -4677,7 +6023,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! be outputting the shallow convective cloud fraction do k=1,pver do i=1,ncol - cloud_frac(i,k) = min(ast(i,k)+deepcu(i,k),1.0_r8) + cloud_frac(i,k) = min(ast(i,k)+deepcu(i,k)+shalcu(i,k),1.0_r8) enddo enddo @@ -4804,6 +6150,8 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call outfld( 'CLUBB_GRID_SIZE', grid_dx, pcols, lchnk ) call outfld( 'QSATFAC', qsatfac, pcols, lchnk) + call outfld( 'PRECSH' , prec_sh(:ncol), pcols, lchnk ) + call outfld( 'TKE_CLUBB', tke, pcols, lchnk ) ! --------------------------------------------------------------- ! ! Writing state variables after EDMF scheme for detailed analysis ! @@ -4822,14 +6170,113 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call outfld( 'edmf_DRY_V' , mf_dry_v_output, pcols, lchnk ) call outfld( 'edmf_MOIST_V' , mf_moist_v_output, pcols, lchnk ) call outfld( 'edmf_MOIST_QC' , mf_moist_qc_output, pcols, lchnk ) + call outfld( 'edmf_precc' , mf_precc_output, pcols, lchnk ) call outfld( 'edmf_S_AE' , s_ae_output, pcols, lchnk ) call outfld( 'edmf_S_AW' , s_aw_output, pcols, lchnk ) + call outfld( 'edmf_S_AWW' , s_aww_output, pcols, lchnk ) call outfld( 'edmf_S_AWTHL' , s_awthl_output, pcols, lchnk ) call outfld( 'edmf_S_AWQT' , s_awqt_output, pcols, lchnk ) call outfld( 'edmf_S_AWU' , s_awu_output, pcols, lchnk ) call outfld( 'edmf_S_AWV' , s_awv_output, pcols, lchnk ) + call outfld( 'edmf_thlforcup', mf_thlforcup_output, pcols, lchnk ) + call outfld( 'edmf_qtforcup' , mf_qtforcup_output, pcols, lchnk ) + call outfld( 'edmf_thlforcdn', mf_thlforcdn_output, pcols, lchnk ) + call outfld( 'edmf_qtforcdn' , mf_qtforcdn_output, pcols, lchnk ) + call outfld( 'edmf_thlforc' , mf_thlforc_output, pcols, lchnk ) + call outfld( 'edmf_qtforc' , mf_qtforc_output, pcols, lchnk ) + call outfld( 'edmf_thlflxup' , mf_thlflxup_output, pcols, lchnk ) + call outfld( 'edmf_qtflxup' , mf_qtflxup_output, pcols, lchnk ) + call outfld( 'edmf_thlflxdn' , mf_thlflxdn_output, pcols, lchnk ) + call outfld( 'edmf_qtflxdn' , mf_qtflxdn_output, pcols, lchnk ) call outfld( 'edmf_thlflx' , mf_thlflx_output, pcols, lchnk ) call outfld( 'edmf_qtflx' , mf_qtflx_output, pcols, lchnk ) + call outfld( 'edmf_thvflx' , mf_thvflx_output, pcols, lchnk ) + call outfld( 'edmf_rcm' , mf_rcm_output, pcols, lchnk ) + call outfld( 'edmf_uflxup' , mf_uflxup_output, pcols, lchnk ) + call outfld( 'edmf_vflxup' , mf_vflxup_output, pcols, lchnk ) + call outfld( 'edmf_uflxdn' , mf_uflxdn_output, pcols, lchnk ) + call outfld( 'edmf_vflxdn' , mf_vflxdn_output, pcols, lchnk ) + call outfld( 'edmf_uflx' , mf_uflx_output, pcols, lchnk ) + call outfld( 'edmf_vflx' , mf_vflx_output, pcols, lchnk ) + call outfld( 'edmf_cloudfrac', mf_cloudfrac_output, pcols, lchnk ) + call outfld( 'edmf_ent' , mf_ent_output, pcols, lchnk ) + call outfld( 'edmf_upa' , mf_upa_output, pcols, lchnk ) + call outfld( 'edmf_upw' , mf_upw_output, pcols, lchnk ) + call outfld( 'edmf_upmf' , mf_upmf_output, pcols, lchnk ) + call outfld( 'edmf_upqt' , mf_upqt_output, pcols, lchnk ) + call outfld( 'edmf_upthl' , mf_upthl_output, pcols, lchnk ) + call outfld( 'edmf_upthv' , mf_upthv_output, pcols, lchnk ) + call outfld( 'edmf_upth' , mf_upth_output, pcols, lchnk ) + call outfld( 'edmf_upqc' , mf_upqc_output, pcols, lchnk ) + call outfld( 'edmf_upbuoy' , mf_upbuoy_output, pcols, lchnk ) + call outfld( 'edmf_upent' , mf_upent_output, pcols, lchnk ) + call outfld( 'edmf_updet' , mf_updet_output, pcols, lchnk ) + call outfld( 'edmf_dnw' , mf_dnw_output, pcols, lchnk ) + call outfld( 'edmf_dnthl' , mf_dnthl_output, pcols, lchnk ) + call outfld( 'edmf_dnqt' , mf_dnqt_output, pcols, lchnk ) + call outfld( 'edmf_sqtup' , mf_sqtup_output, pcols, lchnk ) + call outfld( 'edmf_sqtdn' , mf_sqtdn_output, pcols, lchnk ) + + ! macmic_it==1 ensures that this is ddcp aeraged over the prior time-steps + if (macmic_it==1) call outfld( 'edmf_ztop' , mf_ztop_output, pcols, lchnk ) + if (macmic_it==1) call outfld( 'edmf_ddcp' , mf_ddcp_output, pcols, lchnk ) + + call outfld( 'edmf_L0' , mf_L0_output, pcols, lchnk ) + call outfld( 'edmf_freq' , mf_freq_output, pcols, lchnk ) + call outfld( 'edmf_cape' , mf_cape_output, pcols, lchnk ) + call outfld( 'edmf_cfl' , mf_cfl_output, pcols, lchnk ) + call outfld( 'ICWMRSH' , sh_icwmr, pcols, lchnk ) + end if + + if (macmic_it==cld_macmic_num_steps) then + call outfld( 'qtm_macmic1' , qtm_macmic1, pcols, lchnk ) + call outfld( 'qtm_macmic2' , qtm_macmic2, pcols, lchnk ) + call outfld( 'thlm_macmic1' , thlm_macmic1, pcols, lchnk ) + call outfld( 'thlm_macmic2' , thlm_macmic2, pcols, lchnk ) + + call outfld( 'RCM_CLUBB_macmic' , rcm_macmic, pcols, lchnk ) + call outfld( 'CLDFRAC_CLUBB_macmic' , cldfrac_macmic, pcols, lchnk ) + + call outfld( 'WPTHLP_CLUBB_macmic' , wpthlp_macmic, pcols, lchnk ) + call outfld( 'WPRTP_CLUBB_macmic' , wprtp_macmic, pcols, lchnk ) + call outfld( 'WPTHVP_CLUBB_macmic' , wpthvp_macmic, pcols, lchnk ) + if (do_clubb_mf) then + call outfld( 'edmf_thlflx_macmic' , mf_thlflx_macmic, pcols, lchnk ) + call outfld( 'edmf_qtflx_macmic' , mf_qtflx_macmic, pcols, lchnk ) + call outfld( 'edmf_thvflx_macmic' , mf_thvflx_macmic, pcols, lchnk ) + call outfld( 'up_macmic1' , up_macmic1, pcols, lchnk ) + call outfld( 'up_macmic2' , up_macmic2, pcols, lchnk ) + call outfld( 'dn_macmic1' , dn_macmic1, pcols, lchnk ) + call outfld( 'dn_macmic2' , dn_macmic2, pcols, lchnk ) + call outfld( 'upa_macmic1' , upa_macmic1, pcols, lchnk ) + call outfld( 'upa_macmic2' , upa_macmic2, pcols, lchnk ) + call outfld( 'dna_macmic1' , dna_macmic1, pcols, lchnk ) + call outfld( 'dna_macmic2' , dna_macmic2, pcols, lchnk ) + call outfld( 'thlu_macmic1' , thlu_macmic1, pcols, lchnk ) + call outfld( 'thlu_macmic2' , thlu_macmic2, pcols, lchnk ) + call outfld( 'qtu_macmic1' , qtu_macmic1, pcols, lchnk ) + call outfld( 'qtu_macmic2' , qtu_macmic2, pcols, lchnk ) + call outfld( 'thld_macmic1' , thld_macmic1, pcols, lchnk ) + call outfld( 'thld_macmic2' , thld_macmic2, pcols, lchnk ) + call outfld( 'qtd_macmic1' , qtd_macmic1, pcols, lchnk ) + call outfld( 'qtd_macmic2' , qtd_macmic2, pcols, lchnk ) + call outfld( 'dthl_macmic1' , dthl_macmic1, pcols, lchnk ) + call outfld( 'dthl_macmic2' , dthl_macmic2, pcols, lchnk ) + call outfld( 'dqt_macmic1' , dqt_macmic1, pcols, lchnk ) + call outfld( 'dqt_macmic2' , dqt_macmic2, pcols, lchnk ) + call outfld( 'dthlu_macmic1' , dthlu_macmic1, pcols, lchnk ) + call outfld( 'dthlu_macmic2' , dthlu_macmic2, pcols, lchnk ) + call outfld( 'dqtu_macmic1' , dqtu_macmic1, pcols, lchnk ) + call outfld( 'dqtu_macmic2' , dqtu_macmic2, pcols, lchnk ) + call outfld( 'dthld_macmic1' , dthld_macmic1, pcols, lchnk ) + call outfld( 'dthld_macmic2' , dthld_macmic2, pcols, lchnk ) + call outfld( 'dqtd_macmic1' , dqtd_macmic1, pcols, lchnk ) + call outfld( 'dqtd_macmic2' , dqtd_macmic2, pcols, lchnk ) + call outfld( 'ztop_macmic1' , ztop_macmic1, pcols, lchnk ) + call outfld( 'ztop_macmic2' , ztop_macmic2, pcols, lchnk ) + call outfld( 'ddcp_macmic1' , ddcp_macmic1, pcols, lchnk ) + call outfld( 'ddcp_macmic2' , ddcp_macmic2, pcols, lchnk ) + end if end if ! Output CLUBB history here diff --git a/src/physics/cam/clubb_mf.F90 b/src/physics/cam/clubb_mf.F90 index 898c42004d..7402b775e0 100644 --- a/src/physics/cam/clubb_mf.F90 +++ b/src/physics/cam/clubb_mf.F90 @@ -1,682 +1,3136 @@ -module clubb_mf - -! =============================================================================== ! -! Mass-flux module for use with CLUBB ! -! Together (CLUBB+MF) they comprise a eddy-diffusivity mass-flux approach (EDMF) ! -! =============================================================================== ! - - use shr_kind_mod, only: r8=>shr_kind_r8 - use spmd_utils, only: masterproc - use cam_logfile, only: iulog - - implicit none - private - save - - public :: integrate_mf, & - clubb_mf_readnl, & - do_clubb_mf, & - do_clubb_mf_diag - - real(r8) :: clubb_mf_L0 = 0._r8 - real(r8) :: clubb_mf_ent0 = 0._r8 - integer :: clubb_mf_nup = 0 - logical, protected :: do_clubb_mf = .false. - logical, protected :: do_clubb_mf_diag = .false. - - contains - - subroutine clubb_mf_readnl(nlfile) - - ! =============================================================================== ! - ! MF namelists ! - ! =============================================================================== ! - - use namelist_utils, only: find_group_name - use cam_abortutils, only: endrun - use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_real8, mpi_integer, mpi_logical - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - character(len=*), parameter :: sub = 'clubb_mf_readnl' - - integer :: iunit, read_status, ierr - - - namelist /clubb_mf_nl/ clubb_mf_L0, clubb_mf_ent0, clubb_mf_nup, do_clubb_mf, do_clubb_mf_diag - - if (masterproc) then - open( newunit=iunit, file=trim(nlfile), status='old' ) - call find_group_name(iunit, 'clubb_mf_nl', status=read_status) - if (read_status == 0) then - read(iunit, clubb_mf_nl, iostat=ierr) - if (ierr /= 0) then - call endrun('clubb_mf_readnl: ERROR reading namelist') - end if - end if - close(iunit) - end if - - call mpi_bcast(clubb_mf_L0, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_L0") - call mpi_bcast(clubb_mf_ent0, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_ent0") - call mpi_bcast(clubb_mf_nup, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_nup") - call mpi_bcast(do_clubb_mf, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf") - call mpi_bcast(do_clubb_mf_diag, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_diag") - - if ((.not. do_clubb_mf) .and. do_clubb_mf_diag ) then - call endrun('clubb_mf_readnl: Error - cannot turn on do_clubb_mf_diag without also turning on do_clubb_mf') - end if - - - end subroutine clubb_mf_readnl - - subroutine integrate_mf( nz, dzt, zm, p_zm, iexner_zm, & ! input - p_zt, iexner_zt, & ! input - u, v, thl, qt, thv, & ! input - thl_zm, qt_zm, & ! input - wthl, wqt, pblh, & ! input - dry_a, moist_a, & ! output - plume diagnostics - dry_w, moist_w, & ! output - plume diagnostics - dry_qt, moist_qt, & ! output - plume diagnostics - dry_thl, moist_thl, & ! output - plume diagnostics - dry_u, moist_u, & ! output - plume diagnostics - dry_v, moist_v, & ! output - plume diagnostics - moist_qc, & ! output - plume diagnostics - ae, aw, & ! output - diagnosed fluxes BEFORE mean field update - awthl, awqt, & ! output - diagnosed fluxes BEFORE mean field update - awql, awqi, & ! output - diagnosed fluxes BEFORE mean field update - awu, awv, & ! output - diagnosed fluxes BEFORE mean field update - thlflx, qtflx ) ! output - variables needed for solver - - ! ================================================================================= ! - ! Mass-flux algorithm ! - ! ! - ! Provides rtm and thl fluxes due to mass flux ensemble, ! - ! which are fed into the mixed explicit/implicit clubb solver as explicit terms ! - ! ! - ! Variables needed for solver ! - ! ae = sum_i (1-a_i) ! - ! aw3 = sum (a_i w_i) ! - ! aws3 = sum (a_i w_i*s_i); s=thl*cp ! - ! aws3,awqv3,awql3,awqi3,awu3,awv3 similar as above except for different variables ! - ! ! - ! Mass flux variables are computed on edges (i.e. momentum grid): ! - ! upa,upw,upqt,... ! - ! dry_a,moist_a,dry_w,moist_w, ... ! - ! ! - ! In CLUBB (unlike CAM) nlevs of momentum grid = nlevs of thermodynamic grid, ! - ! due to a subsurface thermodynamic layer. To avoid confusion, below the variables ! - ! are grouped by the grid they are on. ! - ! ! - ! *note that state on the lowest thermo level is equal to state on the lowest ! - ! momentum level due to state_zt(1) = state_zt(2), and lowest momentum level ! - ! is a weighted combination of the lowest two thermodynamic levels. ! - ! ! - ! ---------------------------------Authors---------------------------------------- ! - ! Marcin Kurowski, JPL ! - ! Modified heavily by Mikael Witte, UCLA/JPL for implementation in CESM2/E3SM ! - ! Additional modifications by Adam Herrington, NCAR ! - ! ================================================================================= ! - - use physconst, only: rair, cpair, gravit, latvap, latice, zvir - - integer, intent(in) :: nz - real(r8), dimension(nz), intent(in) :: u, v, & ! thermodynamic grid - thl, thv, & ! thermodynamic grid - qt, & ! thermodynamic grid - dzt, & ! thermodynamic grid - p_zt, iexner_zt, & ! thermodynamic grid - thl_zm, & ! momentum grid - qt_zm, & ! momentum grid - zm, & ! momentum grid - p_zm, iexner_zm ! momentum grid - - real(r8), intent(in) :: wthl,wqt - real(r8), intent(inout) :: pblh - - real(r8),dimension(nz), intent(out) :: dry_a, moist_a, & ! momentum grid - dry_w, moist_w, & ! momentum grid - dry_qt, moist_qt, & ! momentum grid - dry_thl, moist_thl, & ! momentum grid - dry_u, moist_u, & ! momentum grid - dry_v, moist_v, & ! momentum grid - moist_qc, & ! momentum grid - ae, aw, & ! momentum grid - awthl, awqt, & ! momentum grid - awql, awqi, & ! momentum grid - awu, awv, & ! momentum grid - thlflx, qtflx ! momentum grid - - ! =============================================================================== ! - ! INTERNAL VARIABLES - ! - ! sums over all plumes - real(r8), dimension(nz) :: moist_th, dry_th, & ! momentum grid - awqv, awth ! momentum grid - ! - ! updraft properties - real(r8), dimension(nz,clubb_mf_nup) :: upw, upa, & ! momentum grid - upqt, upqc, & ! momentum grid - upqv, upqs, & ! momentum grid - upql, upqi, & ! momentum grid - upth, upthv, & ! momentum grid - upthl, & ! momentum grid - upu, upv ! momentum grid - ! - ! entrainment profiles - real(r8), dimension(nz,clubb_mf_nup) :: ent, entf ! thermodynamic grid - integer, dimension(nz,clubb_mf_nup) :: enti ! thermodynamic grid - ! - ! other variables - integer :: k,i,ih - real(r8), dimension(clubb_mf_nup) :: zcb - real(r8) :: zcb_unset, & - wthv, & - wstar, qstar, thvstar, & - sigmaw, sigmaqt, sigmathv,& - wmin, wmax, & - wlv, wtv, wp, & - B, & ! thermodynamic grid - entexp, entexpu, entw, & ! thermodynamic grid - thln, thvn, thn, & ! momentum grid - qtn, qsn, & ! momentum grid - qcn, qln, qin, & ! momentum grid - un, vn, wn2, & ! momentum grid - lmixn, & ! momentum grid - supqt, supthl ! thermodynamic grid - ! - ! parameters defining initial conditions for updrafts - real(r8),parameter :: pwmin = 1.5_r8, & - pwmax = 3._r8 - - ! - ! alpha, z-scores after Suselj etal 2019 - real(r8),parameter :: alphw = 0.572_r8, & - alphqt = 2.890_r8, & - alphthv = 2.890_r8 - ! - ! w' covariance after Suselj etal 2019 - real(r8),parameter :: cwqt = 0.32_r8, & - cwthv = 0.58_r8 - ! - ! virtual mass coefficients for w-eqn after Suselj etal 2019 - real(r8),parameter :: wa = 1.0_r8, & - wb = 1.5_r8 - ! - ! min values to avoid singularities - real(r8),parameter :: wstarmin = 1.e-3_r8, & - pblhmin = 100._r8 - ! - ! to condensate or not to condensate - logical :: do_condensation = .true. - ! - ! to precip or not to precip - logical :: do_precip = .false. - ! - ! to debug flag (overides stochastic entrainment) - logical :: debug = .false. - real(r8),parameter :: fixent = 0.004_r8 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!!!!!!!!!!!!!!!!!!!! BEGIN CODE !!!!!!!!!!!!!!!!!!!!!!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! INITIALIZE OUTPUT VARIABLES - ! set updraft properties to zero - dry_a = 0._r8 - moist_a = 0._r8 - dry_w = 0._r8 - moist_w = 0._r8 - dry_qt = 0._r8 - moist_qt = 0._r8 - dry_thl = 0._r8 - moist_thl = 0._r8 - dry_u = 0._r8 - moist_u = 0._r8 - dry_v = 0._r8 - moist_v = 0._r8 - moist_qc = 0._r8 - ! outputs - variables needed for solver - aw = 0._r8 - awthl = 0._r8 - awqt = 0._r8 - awqv = 0._r8 - awql = 0._r8 - awqi = 0._r8 - awu = 0._r8 - awv = 0._r8 - thlflx = 0._r8 - qtflx = 0._r8 - - ent = 0._r8 - entf = 0._r8 - enti = 0 - - ! this is the environmental area - by default 1. - ae = 1._r8 - - ! START MAIN COMPUTATION - upw = 0._r8 - upthl = 0._r8 - upthv = 0._r8 - upqt = 0._r8 - upa = 0._r8 - upu = 0._r8 - upv = 0._r8 - upqc = 0._r8 - upth = 0._r8 - upql = 0._r8 - upqi = 0._r8 - upqv = 0._r8 - upqs = 0._r8 - - ! unique identifier - zcb_unset = 9999999._r8 - zcb = zcb_unset - - pblh = max(pblh,pblhmin) - wthv = wthl+zvir*thv(1)*wqt - - ! if surface buoyancy is positive then do mass-flux - if ( wthv > 0._r8 ) then - - if (debug) then - ! overide stochastic entrainment with fixent - ent(:,:) = fixent - else - - ! get entrainment coefficient, dz/L0 - do i=1,clubb_mf_nup - do k=1,nz - entf(k,i) = dzt(k) / clubb_mf_L0 - enddo - enddo - - ! get poisson, P(dz/L0) - call poisson( nz, clubb_mf_nup, entf, enti, u(2:5)) - - ! get entrainment, ent=ent0/dz*P(dz/L0) - do i=1,clubb_mf_nup - do k=1,nz - ent(k,i) = real( enti(k,i))*clubb_mf_ent0/dzt(k) - enddo - enddo - - end if - - ! get surface conditions - wstar = max( wstarmin, (gravit/thv(1)*wthv*pblh)**(1._r8/3._r8) ) - qstar = wqt / wstar - thvstar = wthv / wstar - - sigmaw = alphw * wstar - sigmaqt = alphqt * abs(qstar) - sigmathv = alphthv * abs(thvstar) - - wmin = sigmaw * pwmin - wmax = sigmaw * pwmax - - do i=1,clubb_mf_nup - - wlv = wmin + (wmax-wmin) / (real(clubb_mf_nup,r8)) * (real(i-1, r8)) - wtv = wmin + (wmax-wmin) / (real(clubb_mf_nup,r8)) * real(i,r8) - - upw(1,i) = 0.5_r8 * (wlv+wtv) - upa(1,i) = 0.5_r8 * erf( wtv/(sqrt(2._r8)*sigmaw) ) & - - 0.5_r8 * erf( wlv/(sqrt(2._r8)*sigmaw) ) - - upu(1,i) = u(1) - upv(1,i) = v(1) - - upqt(1,i) = qt(1) + cwqt * upw(1,i) * sigmaqt/sigmaw - upthv(1,i) = thv(1) + cwthv * upw(1,i) * sigmathv/sigmaw - upthl(1,i) = upthv(1,i) / (1._r8+zvir*upqt(1,i)) - - ! get cloud, lowest momentum level - if (do_condensation) then - call condensation_mf(upqt(1,i), upthl(1,i), p_zm(1), iexner_zm(1), & - thvn, qcn, thn, qln, qin, qsn, lmixn) - upthv(1,i) = thvn - upqc(1,i) = qcn - upql(1,i) = qln - upqi(1,i) = qin - upqs(1,i) = qsn - if (qcn > 0._r8) zcb(i) = zm(1) - else - ! assume no cldliq - upqc(1,i) = 0._r8 - end if - - enddo - - ! get updraft properties - do i=1,clubb_mf_nup - do k=1,nz-1 - - ! get microphysics, autoconversion - if (do_precip .and. upqc(k,i) > 0._r8) then - call precip_mf(upqs(k,i),upqt(k,i),upw(k,i),dzt(k+1),zm(k+1)-zcb(i),supqt) - - supthl = -1._r8*lmixn*supqt*iexner_zt(k+1)/cpair - else - supqt = 0._r8 - supthl = 0._r8 - end if - - ! integrate updraft - entexp = exp(-ent(k+1,i)*dzt(k+1)) - entexpu = exp(-ent(k+1,i)*dzt(k+1)/3._r8) - - qtn = qt(k+1) *(1._r8-entexp ) + upqt (k,i)*entexp + supqt - thln = thl(k+1)*(1._r8-entexp ) + upthl(k,i)*entexp + supthl - un = u(k+1) *(1._r8-entexpu) + upu (k,i)*entexpu - vn = v(k+1) *(1._r8-entexpu) + upv (k,i)*entexpu - - ! get cloud, momentum levels - if (do_condensation) then - call condensation_mf(qtn, thln, p_zm(k+1), iexner_zm(k+1), & - thvn, qcn, thn, qln, qin, qsn, lmixn) - if (zcb(i).eq.zcb_unset .and. qcn > 0._r8) zcb(i) = zm(k+1) - else - thvn = thln*(1._r8+zvir*qtn) - end if - - ! get buoyancy - B=gravit*(0.5_r8*(thvn + upthv(k,i))/thv(k+1)-1._r8) - if (debug) then - if ( masterproc ) then - write(iulog,*) "B(k,i), k, i ", B, k, i - end if - end if - - ! get wn^2 - wp = wb*ent(k+1,i) - if (wp==0._r8) then - wn2 = upw(k,i)**2._r8+2._r8*wa*B*dzt(k+1) - else - entw = exp(-2._r8*wp*dzt(k+1)) - wn2 = entw*upw(k,i)**2._r8+wa*B/(wb*ent(k+1,i))*(1._r8-entw) - end if - - if (wn2>0._r8) then - upw(k+1,i) = sqrt(wn2) - upthv(k+1,i) = thvn - upthl(k+1,i) = thln - upqt(k+1,i) = qtn - upqc(k+1,i) = qcn - upqs(k+1,i) = qsn - upu(k+1,i) = un - upv(k+1,i) = vn - upa(k+1,i) = upa(k,i) - upql(k+1,i) = qln - upqi(k+1,i) = qin - upqv(k+1,i) = qtn - qcn - else - exit - end if - enddo - enddo - - ! writing updraft properties for output - do k=1,nz - - ! first sum over all i-updrafts - do i=1,clubb_mf_nup - if (upqc(k,i)>0._r8) then - moist_a(k) = moist_a(k) + upa(k,i) - moist_w(k) = moist_w(k) + upa(k,i)*upw(k,i) - moist_qt(k) = moist_qt(k) + upa(k,i)*upqt(k,i) - moist_thl(k) = moist_thl(k) + upa(k,i)*upthl(k,i) - moist_u(k) = moist_u(k) + upa(k,i)*upu(k,i) - moist_v(k) = moist_v(k) + upa(k,i)*upv(k,i) - moist_qc(k) = moist_qc(k) + upa(k,i)*upqc(k,i) - else - dry_a(k) = dry_a(k) + upa(k,i) - dry_w(k) = dry_w(k) + upa(k,i)*upw(k,i) - dry_qt(k) = dry_qt(k) + upa(k,i)*upqt(k,i) - dry_thl(k) = dry_thl(k) + upa(k,i)*upthl(k,i) - dry_u(k) = dry_u(k) + upa(k,i)*upu(k,i) - dry_v(k) = dry_v(k) + upa(k,i)*upv(k,i) - endif - enddo - - if ( dry_a(k) > 0._r8 ) then - dry_w(k) = dry_w(k) / dry_a(k) - dry_qt(k) = dry_qt(k) / dry_a(k) - dry_thl(k) = dry_thl(k) / dry_a(k) - dry_u(k) = dry_u(k) / dry_a(k) - dry_v(k) = dry_v(k) / dry_a(k) - else - dry_w(k) = 0._r8 - dry_qt(k) = 0._r8 - dry_thl(k) = 0._r8 - dry_u(k) = 0._r8 - dry_v(k) = 0._r8 - endif - - if ( moist_a(k) > 0._r8 ) then - moist_w(k) = moist_w(k) / moist_a(k) - moist_qt(k) = moist_qt(k) / moist_a(k) - moist_thl(k) = moist_thl(k) / moist_a(k) - moist_u(k) = moist_u(k) / moist_a(k) - moist_v(k) = moist_v(k) / moist_a(k) - moist_qc(k) = moist_qc(k) / moist_a(k) - else - moist_w(k) = 0._r8 - moist_qt(k) = 0._r8 - moist_thl(k) = 0._r8 - moist_u(k) = 0._r8 - moist_v(k) = 0._r8 - moist_qc(k) = 0._r8 - endif - - enddo - - do k=1,nz - do i=1,clubb_mf_nup - ae (k) = ae (k) - upa(k,i) - aw (k) = aw (k) + upa(k,i)*upw(k,i) - awu (k) = awu (k) + upa(k,i)*upw(k,i)*upu(k,i) - awv (k) = awv (k) + upa(k,i)*upw(k,i)*upv(k,i) - awthl(k)= awthl(k)+ upa(k,i)*upw(k,i)*upthl(k,i) - awqt(k) = awqt(k) + upa(k,i)*upw(k,i)*upqt(k,i) - awqv(k) = awqv(k) + upa(k,i)*upw(k,i)*upqv(k,i) - awql(k) = awql(k) + upa(k,i)*upw(k,i)*upql(k,i) - awqi(k) = awqi(k) + upa(k,i)*upw(k,i)*upqi(k,i) - enddo - enddo - - do k=1,nz - thlflx(k)= awthl(k) - aw(k)*thl_zm(k) - qtflx(k)= awqt(k) - aw(k)*qt_zm(k) - enddo - - end if ! ( wthv > 0.0 ) - - end subroutine integrate_mf - - subroutine condensation_mf( qt, thl, p, iex, thv, qc, th, ql, qi, qs, lmix ) - ! =============================================================================== ! - ! zero or one condensation for edmf: calculates thv and qc ! - ! =============================================================================== ! - use physconst, only: cpair, zvir, h2otrip - use wv_saturation, only : qsat - - real(r8),intent(in) :: qt,thl,p,iex - real(r8),intent(out):: thv,qc,th,ql,qi,qs,lmix - - !local variables - integer :: niter,i - real(r8) :: diff,t,qstmp,qcold,es,wf - - ! max number of iterations - niter=50 - ! minimum difference - diff=2.e-5_r8 - - qc=0._r8 - t=thl/iex - - !by definition: - ! T = Th*Exner, Exner=(p/p0)^(R/cp) (1) - ! Thl = Th - L/cp*ql/Exner (2) - !so: - ! Th = Thl + L/cp*ql/Exner (3) - ! T = Th*Exner=(Thl+L/cp*ql/Exner)*Exner (4) - ! = Thl*Exner + L/cp*ql - do i=1,niter - wf = get_watf(t) - t = thl/iex+get_alhl(wf)/cpair*qc !as in (4) - - ! qsat, p is in pascal (check!) - call qsat(t,p,es,qstmp) - qcold = qc - qc = max(0.5_r8*qc+0.5_r8*(qt-qstmp),0._r8) - if (abs(qc-qcold)tmax) then - get_watf=1._r8 - else if (tc qstar) then - ! get precip efficiency - tauwgt = (dzcld-zmin)/(zmax-zmin) - tauwgt = min(max(tauwgt,0._r8),1._r8) - tau = tauwgt/tau0 - - ! get source for updraft - Supqt = (qstar-qt)*(1._r8 - exp(-1._r8*tau*dz/w)) - else - Supqt = 0._r8 - end if - - end subroutine precip_mf - - subroutine poisson(nz,nup,lambda,poi,state) - !********************************************************************** - ! Set a unique (but reproduceble) seed for the kiss RNG - ! Call Poisson deviate - ! By Adam Herrington - !********************************************************************** - use shr_RandNum_mod, only: ShrKissRandGen - - integer, intent(in) :: nz,nup - real(r8), dimension(4), intent(in) :: state - real(r8), dimension(nz,nup), intent(in) :: lambda - integer, dimension(nz,nup), intent(out) :: poi - integer, dimension(1,4) :: tmpseed - integer :: i,j - type(ShrKissRandGen) :: kiss_gen - - ! Compute seed - tmpseed(1,1) = int((state(1) - int(state(1))) * 1000000000._r8) - tmpseed(1,2) = int((state(2) - int(state(2))) * 1000000000._r8) - tmpseed(1,3) = int((state(3) - int(state(3))) * 1000000000._r8) - tmpseed(1,4) = int((state(4) - int(state(4))) * 1000000000._r8) - - ! Set seed - kiss_gen = ShrKissRandGen(tmpseed) - - do i=1,nz - do j=1,nup - call knuth(kiss_gen,lambda(i,j),poi(i,j)) - enddo - enddo - - end subroutine poisson - - subroutine knuth(kiss_gen,lambda,kout) - !********************************************************************** - ! Discrete random poisson from Knuth - ! The Art of Computer Programming, v2, 137-138 - ! By Adam Herrington - !********************************************************************** - use shr_RandNum_mod, only: ShrKissRandGen - - type(ShrKissRandGen), intent(inout) :: kiss_gen - real(r8), intent(in) :: lambda - integer, intent(out) :: kout - - ! Local variables - real(r8), dimension(1,1) :: tmpuni - real(r8) :: puni, explam - integer :: k - - k = 0 - explam = exp(-1._r8*lambda) - puni = 1._r8 - do while (puni > explam) - k = k + 1 - call kiss_gen%random(tmpuni) - puni = puni*tmpuni(1,1) - end do - kout = k - 1 - - end subroutine knuth - -end module clubb_mf +module clubb_mf + +! =============================================================================== ! +! Mass-flux module for use with CLUBB ! +! Together (CLUBB+MF) they comprise a eddy-diffusivity mass-flux approach (EDMF) ! +! =============================================================================== ! + + use shr_kind_mod, only: r8=>shr_kind_r8 + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + use cam_abortutils,only: endrun + use time_manager, only: is_first_step, get_nstep + use spmd_utils, only: iam + use physconst, only: cpair, epsilo, gravit, latice, latvap, tmelt, rair, & + cpwv, cpliq, rh2o, zvir, pi + + implicit none + private + save + + public :: integrate_mf, & + clubb_mf_readnl, & + do_clubb_mf, & + do_clubb_mf_diag, & + clubb_mf_nup, & + do_clubb_mf_rad, & + clubb_mf_Lopt, & + clubb_mf_ddalph, & + clubb_mf_up_ndt, & + clubb_mf_cp_ndt, & + do_clubb_mf_cmt, & + do_clubb_mf_addtke, & + clubb_mf_cldfrac_fac + + ! + ! Lopt 0 = fixed L0 + ! 1 = tke_clubb L0 + ! 2 = wpthlp_clubb L0 + ! 3 = test plume L0 + ! 4 = lel + ! 5 = cape + ! 6 = ztopm1 + ! 7 = rel.hum. at 500 hPa + ! 8 = column int. rel.hum. + integer :: clubb_mf_Lopt = 0 + real(r8) :: clubb_mf_a0 = 0._r8 + real(r8) :: clubb_mf_b0 = 0._r8 + real(r8) :: clubb_mf_L0 = 0._r8 + real(r8) :: clubb_mf_ent0 = 0._r8 + real(r8) :: clubb_mf_alphturb= 0._r8 + real(r8) :: clubb_mf_max_L0 = 0._r8 + real(r8) :: clubb_mf_fdd = 0._r8 + real(r8) :: clubb_mf_ddalph = 0._r8 + real(r8) :: clubb_mf_ddbeta = 0._r8 + real(r8) :: clubb_mf_pwfac = 0._r8 + real(r8) :: clubb_mf_ddexp = 0._r8 + real(r8) :: clubb_mf_cldfrac_fac = 1._r8 + integer :: clubb_mf_up_ndt = 1 + integer :: clubb_mf_cp_ndt = 1 + integer :: clubb_mf_kseed = 1 + integer, protected :: clubb_mf_nup = 0 + logical, protected :: do_clubb_mf = .false. + logical, protected :: do_clubb_mf_diag = .false. + logical, protected :: do_clubb_mf_rad = .false. + logical, protected :: do_clubb_mf_addtke = .false. + logical, protected :: do_clubb_mf_coldpool = .false. + logical, protected :: do_clubb_mf_ustar = .false. + logical, protected :: do_clubb_mf_mixd = .false. + logical, protected :: do_clubb_mf_precip = .false. + logical, protected :: do_clubb_mf_rhtke = .false. + logical, protected :: do_clubb_mf_cmt = .false. + logical, protected :: do_clubb_mf_aloft = .false. + logical, protected :: do_clubb_mf_coldpool_init = .false. + logical, protected :: do_clubb_mf_coldpool_perplume = .false. + logical, protected :: do_clubb_mf_lscale_perplume = .false. + logical :: tht_tweaks = .true. + integer :: mf_num_cin = 5 + + contains + + subroutine clubb_mf_readnl(nlfile) + + ! =============================================================================== ! + ! MF namelists ! + ! =============================================================================== ! + + use namelist_utils, only: find_group_name + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_real8, mpi_integer, mpi_logical + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + character(len=*), parameter :: sub = 'clubb_mf_readnl' + + integer :: iunit, read_status, ierr + + + namelist /clubb_mf_nl/ clubb_mf_Lopt, clubb_mf_a0, clubb_mf_b0, clubb_mf_L0, clubb_mf_ent0, clubb_mf_alphturb, & + clubb_mf_nup, clubb_mf_max_L0, do_clubb_mf, do_clubb_mf_diag, do_clubb_mf_precip, do_clubb_mf_rad, & + clubb_mf_fdd, do_clubb_mf_coldpool, clubb_mf_ddalph, clubb_mf_ddbeta, clubb_mf_pwfac, do_clubb_mf_ustar, & + clubb_mf_ddexp, do_clubb_mf_mixd, clubb_mf_up_ndt, clubb_mf_cp_ndt, do_clubb_mf_rhtke, do_clubb_mf_cmt, & + do_clubb_mf_coldpool_init, do_clubb_mf_coldpool_perplume, do_clubb_mf_lscale_perplume, clubb_mf_kseed, & + do_clubb_mf_addtke, do_clubb_mf_aloft, clubb_mf_cldfrac_fac + + if (masterproc) then + open( newunit=iunit, file=trim(nlfile), status='old' ) + call find_group_name(iunit, 'clubb_mf_nl', status=read_status) + if (read_status == 0) then + read(iunit, clubb_mf_nl, iostat=ierr) + if (ierr /= 0) then + call endrun('clubb_mf_readnl: ERROR reading namelist') + end if + end if + close(iunit) + end if + + call mpi_bcast(clubb_mf_Lopt, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_Lopt") + call mpi_bcast(clubb_mf_a0, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_a0") + call mpi_bcast(clubb_mf_b0, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_b0") + call mpi_bcast(clubb_mf_L0, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_L0") + call mpi_bcast(clubb_mf_ent0, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_ent0") + call mpi_bcast(clubb_mf_alphturb,1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_alphturb") + call mpi_bcast(clubb_mf_nup, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_nup") + call mpi_bcast(clubb_mf_max_L0, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_max_L0") + call mpi_bcast(do_clubb_mf, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf") + call mpi_bcast(do_clubb_mf_diag, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_diag") + call mpi_bcast(do_clubb_mf_precip, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_precip") + call mpi_bcast(do_clubb_mf_rad, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_rad") + call mpi_bcast(clubb_mf_fdd, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_fdd") + call mpi_bcast(do_clubb_mf_coldpool, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_coldpool") + call mpi_bcast(clubb_mf_ddalph, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_ddalph") + call mpi_bcast(clubb_mf_ddbeta, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_ddbeta") + call mpi_bcast(clubb_mf_pwfac, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_pwfac") + call mpi_bcast(clubb_mf_up_ndt, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_up_ndt") + call mpi_bcast(clubb_mf_cp_ndt, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_cp_ndt") + call mpi_bcast(do_clubb_mf_ustar, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_ustar") + call mpi_bcast(clubb_mf_ddexp, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_ddexp") + call mpi_bcast(do_clubb_mf_mixd, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_mixd") + call mpi_bcast(do_clubb_mf_rhtke, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_rhtke") + call mpi_bcast(do_clubb_mf_cmt, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_cmt") + call mpi_bcast(clubb_mf_kseed, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_kseed") + call mpi_bcast(do_clubb_mf_coldpool_init, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_coldpool_init") + call mpi_bcast(do_clubb_mf_coldpool_perplume, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_coldpool_perplume") + call mpi_bcast(do_clubb_mf_lscale_perplume, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_lscale_perplume") + call mpi_bcast(do_clubb_mf_addtke, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_addtke") + call mpi_bcast(do_clubb_mf_aloft, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_clubb_mf_aloft") + call mpi_bcast(clubb_mf_cldfrac_fac, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mf_cldfrac_fac") + + if ((.not. do_clubb_mf) .and. do_clubb_mf_diag ) then + call endrun('clubb_mf_readnl: Error - cannot turn on do_clubb_mf_diag without also turning on do_clubb_mf') + end if + + + end subroutine clubb_mf_readnl + + subroutine integrate_mf( nz, & ! input + rho_zm, dzm, zm, p_zm, iexner_zm, & ! input + rho_zt, dzt, zt, p_zt, iexner_zt, & ! input + u, v, thl, qt, thv, & ! input + ktropo, w, th, qv, qc, & ! input + thl_zm, qt_zm, thv_zm, & ! input + th_zm, qv_zm, qc_zm, & ! input + ustar, ths, wthl_sfc, wqt_sfc, pblh, & ! input + wpthlp_env, tke, tpert, ztopm1, rhinv, & ! input + wpthvp_env, wpqtp_env, mcape, ddcp, cbm1, & ! output + upa, dna, & ! output + upw, dnw, & ! output + upmf, & ! output + upqt, dnqt, & ! output + upthl, dnthl, & ! output + upthv, dnthv, & ! output + upth, dnth, & ! output + upqc, dnqc, & ! output + upbuoy, & ! output + upent, & ! output + updet, & ! output + dry_a, moist_a, & ! output + dry_w, moist_w, & ! output + dry_qt, moist_qt, & ! output + dry_thl, moist_thl, & ! output + dry_u, moist_u, & ! output + dry_v, moist_v, & ! output + moist_qc, & ! output + ae, & + ac, aup, adn, & + aw, awup, awdn, & + aww, awwup, awwdn, & + awthlup, awqtup, awuup, awvup, & ! output + awthldn, awqtdn, awudn, awvdn, & ! output + awthl, awqt, & ! output + awu, awv, & ! output + thlflxup,qtflxup, uflxup, vflxup, & ! output + thlflxdn,qtflxdn, uflxdn, vflxdn, & ! output + thlflx, qtflx, uflx, vflx, & ! output - variables needed for solver + thvflx, & ! output + sqtup, sthlup, & ! output + sqtdn, sthldn, & ! output + sqt, sthl, & ! output - variables needed for solver + precc, & ! output + ztop, dynamic_L0 ) + + ! ================================================================================= ! + ! Mass-flux algorithm ! + ! ! + ! Provides rtm and thl fluxes due to mass flux ensemble, ! + ! which are fed into the mixed explicit/implicit clubb solver as explicit terms ! + ! ! + ! Mass flux variables are computed on edges (i.e. momentum grid): ! + ! upa,upw,upqt,... ! + ! dry_a,moist_a,dry_w,moist_w, ... ! + ! ! + ! In CLUBB (unlike CAM) nlevs of momentum grid = nlevs of thermodynamic grid, ! + ! due to a subsurface thermodynamic layer. To avoid confusion, below the variables ! + ! are grouped by the grid they are on. ! + ! ! + ! *note that state on the lowest thermo level is equal to state on the lowest ! + ! momentum level due to state_zt(1) = state_zt(2), and lowest momentum level ! + ! is a weighted combination of the lowest two thermodynamic levels. ! + ! ! + ! ---------------------------------Authors---------------------------------------- ! + ! Marcin Kurowski, JPL ! + ! Modified heavily by Mikael Witte, UCLA/JPL for implementation in CESM2/E3SM ! + ! Additional modifications by Adam Herrington, NCAR ! + ! ================================================================================= ! + + use wv_saturation, only : qsat + + integer, intent(in) :: nz, ktropo + real(r8), dimension(nz), intent(in) :: u, v, & ! thermodynamic grid + w, & + thl, thv, & ! thermodynamic grid + th, qv, & ! thermodynamic grid + qt, qc, & ! thermodynamic grid + p_zt, iexner_zt, & ! thermodynamic grid + dzt, rho_zt, & ! thermodynamic grid + zt, & ! thermodynamic grid + thl_zm, thv_zm, & ! momentum grid + th_zm, qv_zm, & + qt_zm, qc_zm, & ! momentum grid + p_zm, iexner_zm, & ! momentum grid + dzm, rho_zm, & ! momentum grid + zm, & ! momentum grid + tke, wpthlp_env, & ! momentum grid + wpthvp_env, wpqtp_env + + real(r8), intent(in) :: wthl_sfc,wqt_sfc + real(r8), intent(in) :: pblh,tpert + real(r8), intent(in) :: rhinv + real(r8), intent(in) :: ths,ustar + real(r8), intent(inout) :: cbm1 + + real(r8),dimension(clubb_mf_nup), intent(inout) :: ztopm1,ddcp + + real(r8),dimension(nz,clubb_mf_nup), intent(out) :: upa, & ! momentum grid + upw, & ! momentum grid + upmf, & ! momentum grid + upqt, & ! momentum grid + upthl, & ! momentum grid + upthv, & ! momentum grid + upth, & ! momentum grid + upqc, & ! momentum grid + upbuoy, & ! momentum grid + upent, & ! momentum grid + updet + ! + real(r8),dimension(nz,clubb_mf_nup), intent(out) :: dna, & ! momentum grid + dnw, & ! momentum grid + dnqt, & ! momentum grid + dnthl, & ! momentum grid + dnthv, & ! momentum grid + dnth, & ! momentum grid + dnqc + ! + real(r8),dimension(nz), intent(out) :: dry_a, moist_a, & ! momentum grid + dry_w, moist_w, & ! momentum grid + dry_qt, moist_qt, & ! momentum grid + dry_thl, moist_thl, & ! momentum grid + dry_u, moist_u, & ! momentum grid + dry_v, moist_v, & ! momentum grid + moist_qc ! momentum grid + ! + real(r8),dimension(nz), intent(out) :: ae, & + ac, aup, adn, & + aw, awup, awdn, & + aww, awwup, awwdn, & + awthlup, awqtup, awuup, awvup, & ! momentum grid + awthldn, awqtdn, awudn, awvdn, & ! momentum grid + awthl, awqt, & ! momentum grid + awu, awv, & ! momentum grid + thlflxup,qtflxup, uflxup, vflxup, & ! momentum grid + thlflxdn,qtflxdn, uflxdn, vflxdn, & ! momentum grid + thlflx, qtflx, uflx, vflx, & ! momentum grid + thvflx, & + sqtup, sthlup, & ! thermodynamic grid + sqtdn, sthldn, & ! thermodynamic grid + sqt, sthl, & ! thermodynamic grid + precc + + real(r8),dimension(clubb_mf_nup), intent(out) :: ztop, dynamic_L0, mcape + ! =============================================================================== ! + ! INTERNAL VARIABLES + ! + ! sums over all plumes + real(r8), dimension(nz) :: moist_th, dry_th, & + thl_env, qt_env, & + thv_env, & + thvflxup, thvflxdn, & + awthvup, awthvdn + ! + ! updraft properties + real(r8), dimension(nz,clubb_mf_nup) :: upqv, upqs, & ! momentum grid + upql, upqi, & ! momentum grid + upu, upv, & ! momentum grid + uplmix, upauto ! momentum grid + ! + ! downdraft properties + real(r8), dimension(nz,clubb_mf_nup) :: dnqs, & ! momentum grid + dnql, dnqi, & ! momentum grid + dnu, dnv, & ! momentum grid + dnlmix ! momentum grid + ! + ! microphyiscs terms + real(r8), dimension(nz,clubb_mf_nup) :: supqt, supthl, & ! thermodynamic grid + sdnqt, sdnthl, & ! thermodynamic grid + uprr, dnrr + ! + ! entrainment profiles + real(r8), dimension(nz,clubb_mf_nup) :: entf, mix ! thermodynamic grid + integer, dimension(nz,clubb_mf_nup) :: enti ! thermodynamic grid + ! + ! other variables + integer :: k,i,kstart,ddtop,kcb,kpbl,kmid,nbot !+++arh + integer, dimension(clubb_mf_nup) :: ddbot,kcbarr + real(r8), dimension(clubb_mf_nup) :: zcb,cpfac + real(r8) :: zcb_unset, & + wthv_sfc, wthv, wqt, & + ddint, iddcp, & + wstar, qstar, thvstar, & + sigmaw, sigmaqt, sigmathv,& + convh, wmin, wmax, & + wlv, wtv, wp, & + B, & ! thermodynamic grid + entexp, entexpu, entw, & ! thermodynamic grid + Mn, & ! momentum grid + eturb, det, lmixt, & ! thermodynamic grid + qtovqs, sevap, taum1, & ! thermodynamic grid + sqtint, sthlint, alphint, & + qtmp, betathl, betaqt, & ! thermodynamic grid + thln, thvn, thn, & ! momentum grid + qtn, qsn, & ! momentum grid + qcn, qln, qin, & ! momentum grid + un, vn, wn2, & ! momentum grid + wn, & ! momentum grid + lmixn, srfarea, & ! momentum grid + srfwqtu, srfwthvu, & + facqtu, facthvu, & + zsub, wcb, rh_L0, & + dzext !+++arh + +! ! +! ! cape variables +! real(r8), dimension(nz) :: t_zt +! real(r8), dimension(nz-1) :: tp, qstp +! !real(r8), dimension(nz-1,clubb_mf_nup) :: dmpdz +! !real(r8), dimension(clubb_mf_nup) :: tl, & +! ! cape, cin +! !integer, dimension(clubb_mf_nup) :: lcl, lel +! real(r8), dimension(nz-1,1) :: dmpdz +! real(r8), dimension(1) :: tl, & +! cape, cin +! integer, dimension(1) :: lcl, lel +! real(r8) :: landfrac +! integer :: kpbl, msg, & +! lon, mx + ! + ! limit convective area + logical :: limarea = .false. + real(r8),parameter :: amax = 0.6_r8 + ! + ! buoyancy sorting variables + logical :: bsort = .false. + real(r8),parameter :: rle = 0.1_r8 + integer :: niter_xc = 1 + integer :: kk, status, iter_xc + real(r8) :: tlm, excessm, qsm, & + tln, excessn, es, & + xc, xsat, x_en, & + x_cu, xs1, xs2, & + aquad, bquad, cquad, & + thlxsat, thvxsat, qtxsat, & + thv_x0, thv_x1, cridis, & + thln0, qtn0, wn0, & + entn, detn, mfn, & + ee2, ud2 + + ! + ! parameters defining initial conditions for updrafts + real(r8),parameter :: pwmin = 1.5_r8, & + pwmax = 3._r8 + + ! + ! alpha relates star qunataties to stddev after Suselj etal 2019 + real(r8),parameter :: alphw = 0.572_r8, & + alphqt = 2.890_r8, & + alphthv = 2.890_r8 + ! + ! w' covariance after Suselj etal 2019 + real(r8),parameter :: cwqt = 0.32_r8, & + cwthv = 0.58_r8 + ! + ! virtual mass coefficients for w-eqn after Suselj etal 2019 + real(r8),parameter :: wa = 1.0_r8, & + wb = 1.5_r8 + ! + ! min values to avoid singularities + real(r8),parameter :: wstarmin = 1.e-3_r8, & + pblhmin = 100._r8 + ! + ! evaporation efficiency after Suselj etal 2019 + real(r8),parameter :: ke = 2.5e-4_r8 + ! + ! height here downdrafts feel the surface + real(r8),parameter :: z00dn = 1.e3_r8, & + tinynum = 1.e-7_r8 + ! + ! to fix entrainmnet rate + logical :: fixent = .false. + ! + ! fixed entrainment rate + real(r8),parameter :: fixent_ent = 2.e-4_r8 + ! + ! Arakawa and Schubert detrainment limiter + logical :: do_aspd = .false. + ! + ! Lower limit on entrainment length scale + real(r8),parameter :: min_L0 = 0.5_r8 + ! + ! limiter for tke enahnced fractional entrainment + ! (only used when do_aspd = .true.) + real(r8),parameter :: max_eturb = 10._r8 + ! + ! to condensate or not to condensate + logical :: do_condensation = .true. + ! + ! use implicit method for plume updraft velocity + logical :: do_implicit = .false. + ! + ! to scale surface fluxes + logical :: scalesrf = .false. + ! + ! minimum downdraft speed + real(r8),parameter :: mindnw = 1.E-2_r8 + ! + ! limiter on cold pool effects + real(r8),parameter :: max_cpfac = 5._r8 + ! + ! max limiter on cold pool init effects + real(r8),parameter :: max_cpinit = 0.5_r8 + ! + ! to scale surface fluxes + logical :: aloft = .false. + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!! BEGIN CODE !!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! INITIALIZE OUTPUT VARIABLES + dry_a = 0._r8 + moist_a = 0._r8 + dry_w = 0._r8 + moist_w = 0._r8 + dry_qt = 0._r8 + moist_qt = 0._r8 + dry_thl = 0._r8 + moist_thl = 0._r8 + dry_u = 0._r8 + moist_u = 0._r8 + dry_v = 0._r8 + moist_v = 0._r8 + moist_qc = 0._r8 + + ! this is the environmental area - by default 1. + ae = 1._r8 + ac = 0._r8 + aup = 0._r8 + adn = 0._r8 + aw = 0._r8 + awup = 0._r8 + awdn = 0._r8 + aww = 0._r8 + awwup = 0._r8 + awwdn = 0._r8 + awuup = 0._r8 + awvup = 0._r8 + awudn = 0._r8 + awvdn = 0._r8 + awthvup = 0._r8 + awthvdn = 0._r8 + awthlup = 0._r8 + awqtup = 0._r8 + awthldn = 0._r8 + awqtdn = 0._r8 + awthl = 0._r8 + awqt = 0._r8 + awu = 0._r8 + awv = 0._r8 + thvflxup = 0._r8 + thlflxup = 0._r8 + qtflxup = 0._r8 + thvflxdn = 0._r8 + thlflxdn = 0._r8 + qtflxdn = 0._r8 + thvflx = 0._r8 + thlflx = 0._r8 + uflxup = 0._r8 + vflxup = 0._r8 + uflxdn = 0._r8 + vflxdn = 0._r8 + uflx = 0._r8 + vflx = 0._r8 + qtflx = 0._r8 + sqtup = 0._r8 + sthlup = 0._r8 + sqtdn = 0._r8 + sthldn = 0._r8 + sqt = 0._r8 + sthl = 0._r8 + precc = 0._r8 + + mix = 0._r8 + entf = 0._r8 + enti = 0 + det = 0._r8 + + ! START MAIN COMPUTATION + upw = 0._r8 + upth = 0._r8 + upthl = 0._r8 + upthv = 0._r8 + upqt = 0._r8 + upa = 0._r8 + upmf = 0._r8 + upu = 0._r8 + upv = 0._r8 + upqc = 0._r8 + upth = 0._r8 + upql = 0._r8 + upqi = 0._r8 + upqv = 0._r8 + upqs = 0._r8 + upbuoy= 0._r8 + uplmix= 0._r8 + uprr = 0._r8 + supqt = 0._r8 + supthl= 0._r8 + upent = 0._r8 + updet = 0._r8 + upauto= 0._r8 + + dnw = 0._r8 + dna = 0._r8 + dnu = 0._r8 + dnv = 0._r8 + dnqt = 0._r8 + dnthl = 0._r8 + dnthv = 0._r8 + dnrr = 0._r8 + dnth = 0._r8 + dnqc = 0._r8 + dnql = 0._r8 + dnqi = 0._r8 + dnqs = 0._r8 + dnlmix= 0._r8 + sdnqt = 0._r8 + sdnthl= 0._r8 + + dynamic_L0 = 0._r8 + ztop = 0._r8 + ddbot= 0 + + if (bsort) then + niter_xc = 3 + limarea = .true. + end if + + ! unique identifier + zcb_unset = 9999999._r8 + zcb = zcb_unset + + ! surface buoyancy flux + !wthv = wthl+zvir*ths*wqt + wthv_sfc = wthl_sfc+zvir*ths*wqt_sfc + + if (do_clubb_mf_aloft .and. wthv_sfc < 0.01_r8) then + aloft = .true. + + kpbl = 1 + do while (zm(kpbl) < pblh) + kpbl = kpbl+1 + end do + + kmid = 1 + ! Use a pressure-based criterion to locate the mid-level within the + ! troposphere. A threshold of ~500 hPa is preferred over the previous + ! fixed height (9 km) because it better represents the tropopause + ! location across different atmospheric conditions. + do while (p_zm(kmid) > 500.E2_r8) + kmid = kmid+1 + end do + + kstart = maxloc(wpthvp_env(kpbl:kmid),DIM=1) + kstart = kstart + kpbl - 1 + + wthv = wpthvp_env(kstart) + wqt = wpqtp_env(kstart) + + if (kstart == nz) then + wthv = 0._r8 + wqt = 0._r8 + end if + + else + aloft = .false. + kstart = 1 + wthv = wthv_sfc + wqt = wqt_sfc + end if + + ! if surface buoyancy is positive then do mass-flux + !if ( wthv > 0._r8 ) then + if ( wthv > 0._r8 .and. wqt > 0._r8) then + + if (do_clubb_mf_mixd) then + convh = max(cbm1,pblhmin) + else + convh = max(pblh,pblhmin) + end if + + ! --------------------------------------------------------- ! + ! Initialize using Deardorff convective velocity scale ! + ! --------------------------------------------------------- ! + + wstar = max( wstarmin, (gravit/thv(kstart)*wthv*convh)**(1._r8/3._r8) ) + + ! --------------------------------------------------------- ! + ! Compute cold pool feedback parameter ! + ! --------------------------------------------------------- ! + + cpfac(:) = 1._r8 + if (do_clubb_mf_coldpool) then + do i=1,clubb_mf_nup + cpfac(i) = min( (max(ddcp(i)/wstar,1._r8))**clubb_mf_ddbeta, max_cpfac ) + end do + end if + + ! --------------------------------------------------------- ! + ! Construct tri-variate PDF at the surface from wstar ! + ! and initialize plume thv, qt, w ! + ! --------------------------------------------------------- ! + + if (do_clubb_mf_ustar) then + qstar = wqt / max(wstarmin,ustar) + thvstar = wthv / max(wstarmin,ustar) + else + qstar = wqt / wstar + thvstar = wthv / wstar + end if + + do i=1,clubb_mf_nup + + if (do_clubb_mf_coldpool_init) then + sigmaw = alphw * wstar * (1._r8 + max_cpinit*cpfac(i)/max_cpfac) + sigmaqt = alphqt * abs(qstar) * (1._r8 + max_cpinit*cpfac(i)/max_cpfac) + sigmathv = alphthv * abs(thvstar) * (1._r8 + max_cpinit*cpfac(i)/max_cpfac) + else + sigmaw = alphw * wstar + sigmaqt = alphqt * abs(qstar) + sigmathv = alphthv * abs(thvstar) + end if + + wmin = sigmaw * pwmin + wmax = sigmaw * pwmax + + wlv = wmin + (wmax-wmin) / (real(clubb_mf_nup,r8)) * (real(i-1, r8)) + wtv = wmin + (wmax-wmin) / (real(clubb_mf_nup,r8)) * real(i,r8) + + upw(kstart,i) = 0.5_r8 * (wlv+wtv) + upa(kstart,i) = 0.5_r8 * erf( wtv/(sqrt(2._r8)*sigmaw) ) & + - 0.5_r8 * erf( wlv/(sqrt(2._r8)*sigmaw) ) + + upu(kstart,i) = u(kstart) + upv(kstart,i) = v(kstart) + + upqt(kstart,i) = cwqt * upw(kstart,i) * sigmaqt/sigmaw + upthv(kstart,i) = cwthv * upw(kstart,i) * sigmathv/sigmaw + enddo + + facqtu=1._r8 + facthvu=1._r8 + if (scalesrf) then + ! scale surface fluxes + ! (req'd for conservation if not running with zero-flux b.c.'s) + srfwqtu = 0._r8 + srfwthvu = 0._r8 + srfarea = 0._r8 + do i=1,clubb_mf_nup + srfwqtu=srfwqtu+upqt(kstart,i)*upw(kstart,i)*upa(kstart,i) + srfwthvu=srfwthvu+upthv(kstart,i)*upw(kstart,i)*upa(kstart,i) + srfarea = srfarea+upa(kstart,i) + end do + facqtu=srfarea*wqt/srfwqtu + facthvu=srfarea*wthv/srfwthvu + end if + + do i=1,clubb_mf_nup + + !betaqt = (qt(4)-qt(2))/(0.5_r8*(dzt(4)+2._r8*dzt(3)+dzt(2))) + !betathl = (thv(4)-thv(2))/(0.5_r8*(dzt(4)+2._r8*dzt(3)+dzt(2))) + betaqt = (qt(kstart+3)-qt(kstart+1))/(0.5_r8*(dzt(kstart+3)+2._r8*dzt(kstart+2)+dzt(kstart+1))) + betathl = (thv(kstart+3)-thv(kstart+1))/(0.5_r8*(dzt(kstart+3)+2._r8*dzt(kstart+2)+dzt(kstart+1))) + + !upqt(1,i)= qt(2)-betaqt*0.5_r8*(dzt(2)+dzt(1))+facqtu*upqt(1,i) + !upthv(1,i)= thv(2)-betathl*0.5_r8*(dzt(2)+dzt(1))+facthvu*upthv(1,i) + if (.not.aloft) then + upqt(kstart,i)= qt(kstart+1)-betaqt*0.5_r8*(dzt(kstart+1)+dzt(kstart))+facqtu*upqt(kstart,i) + upthv(kstart,i)= thv(kstart+1)-betathl*0.5_r8*(dzt(kstart+1)+dzt(kstart))+facthvu*upthv(kstart,i) + else + upqt(kstart,i)= qt(kstart)+upqt(kstart,i) + upthv(kstart,i)= thv(kstart)+upthv(kstart,i) + if (w(kstart) > 0._r8) upw(kstart,i)= w(kstart)+upw(kstart,i) + end if + + upthl(kstart,i) = upthv(kstart,i) / (1._r8+zvir*upqt(kstart,i)) + upth(kstart,i) = upthl(kstart,i) + upmf(kstart,i) = rho_zm(kstart)*upa(kstart,i)*upw(kstart,i) + + ! get cloud, lowest momentum level + if (do_condensation) then + call condensation_mf(upqt(kstart,i), upthl(kstart,i), p_zm(kstart), iexner_zm(kstart), & + thvn, qcn, thn, qln, qin, qsn, lmixn) + upthv(kstart,i) = thvn + upqc(kstart,i) = qcn + upql(kstart,i) = qln + upqi(kstart,i) = qin + upqs(kstart,i) = qsn + upth(kstart,i) = thn + if (qcn > 0._r8) zcb(i) = zm(kstart) + else + ! assume no cldliq + upqc(kstart,i) = 0._r8 + end if + end do + + ! if aloft extend the mass flux plume below kstart nbot levels + if (aloft) then + zsub = zm(kstart) + dzext = 1000._r8 + !if greater than dzext above the surface + if (zsub > dzext) then + ! find nbot levs below kstart + nbot = 0 + do k=kstart-1,nz,-1 + if ((zm(kstart)-zm(k)) < dzext) then + nbot = nbot + 1 + end if + end do + else + !else set dxext to height above the suface + dzext = zm(kstart) - zm(nz) + nbot = kstart-nz + end if + + zsub = zm(kstart) + do i=1,clubb_mf_nup + wcb = upw(kstart,i) + do k=kstart-1,kstart-nbot,-1 + upw(k,i) = wcb - (wcb/(dzext**clubb_mf_ddexp))*(zsub - zm(k))**clubb_mf_ddexp + upa(k,i) = upa(kstart,i) + upmf(k,i) = rho_zm(k)*upa(k,i)*upw(k,i) + + upu(k,i) = upu(kstart,i) + upv(k,i) = upv(kstart,i) + upqt(k,i) = upqt(kstart,i) + upthv(k,i) = upthv(kstart,i) + upthl(k,i) = upthl(kstart,i) + upth(k,i) = upth(kstart,i) + upqc(k,i) = upqc(kstart,i) + upql(k,i) = upql(kstart,i) + upqi(k,i) = upqi(kstart,i) + upqs(k,i) = upqs(kstart,i) + end do + end do + end if + + do i=1,clubb_mf_nup + ! --------------------------------------------------------- ! + ! Calculate ztop and dynamic_L based on value of namelist ! + ! --------------------------------------------------------- ! + call get_Lscale (nz, zm, tke, wpthlp_env, dzt, iexner_zm, iexner_zt, p_zm, qt, thv, thl, th, & + wmax, wmin, sigmaw, sigmaqt, sigmathv, cwqt, cwthv, zcb_unset, wa, wb, & + do_condensation, qv, p_zt, zt, tpert, pblh, convh, rhinv, ztopm1(i), dynamic_L0(i), ztop(i), mcape(i)) + + ! cold pool feedback on the entrainmnet length scale + dynamic_L0(i) = dynamic_L0(i) * cpfac(i) + + ! limit max/min + dynamic_L0(i) = max(min_L0,dynamic_L0(i)) + dynamic_L0(i) = min(clubb_mf_max_L0,dynamic_L0(i)) + + ! --------------------------------------------------------- ! + ! Stochastic entrainmnet calculation ! + ! From Suselj et al 2019, after Romps and Kuang 2010 ! + ! (ideally we wouldn't fill the entire arrray w/ the RNG, ! + ! but the RNG doesn't work properly when it operates on ! + ! the entire array. I'm not sure why this is happening.) ! + ! --------------------------------------------------------- ! + do k=1,nz-1 + ! get entrainment coefficient, dz/L0 + entf(k,i) = dzt(k) / dynamic_L0(i) + end do + ! + end do + + ! get poisson, P(dz/L0) + call poisson( nz, clubb_mf_nup, entf, enti, u(clubb_mf_kseed+1:clubb_mf_kseed+4)) + + ! --------------------------------------------------------- ! + ! Main upward sweep to compute updraft properties ! + ! ! + ! --------------------------------------------------------- ! + do i=1,clubb_mf_nup + do k=kstart,nz-1 + + ! get microphysics, autoconversion + if (do_clubb_mf_precip .and. upqc(k,i) > 0._r8) then + call precip_mf(upqs(k,i),upqt(k,i),upw(k,i),dzt(k+1),zm(k+1)-zcb(i),supqt(k+1,i)) + supthl(k+1,i) = -1._r8*lmixn*supqt(k+1,i)*iexner_zt(k+1)/cpair + else + supqt(k+1,i) = 0._r8 + supthl(k+1,i) = 0._r8 + end if + + ! compute mixing rate + if (fixent) then + mix(k+1,i) = fixent_ent + else + ! get entrainment, ent=ent0/dz*P(dz/L0) + mix(k+1,i) = real( enti(k+1,i))*clubb_mf_ent0/dzt(k+1) + end if + + do iter_xc = 1, niter_xc + + if (bsort) then + if (iter_xc==1) then + qtn = upqt(k,i) + thln = upthl(k,i) + wn = upw(k,i) + else + qtn = 0.5_r8*(qtn + qtn0) + thln = 0.5_r8*(thln + thln0) + wn = 0.5_r8*(wn + wn0) + end if + + ! save this iteration + qtn0 = qtn + thln0 = thln + wn0 = wn + + ! --------------------------------------------------------- ! + ! Compute excess water to derive neutral mixing fraction ! + ! after Bretherton et al 2014 ! + ! --------------------------------------------------------- ! + + ! qexcess of the envrionment + tlm = thl_zm(k+1)/iexner_zm(k+1) + call qsat(tlm,p_zm(k+1),es,qsm) + excessm = qt_zm(k+1) - qsm + + ! qexcess in plume + tln = thln/iexner_zm(k+1) + call qsat(tln,p_zm(k+1),es,qsn) + excessn = qtn - qsn + + call condensation_mf(qtn, thln, p_zm(k+1), iexner_zm(k+1), & + thvn, qcn, thn, qln, qin, qsn, lmixn) + + ! critical stopping distance + cridis = rle*ztopm1(i) + + ! ----------------------------------------------------------------- ! + ! Case 1 : When both cumulus and env. are unsaturated or saturated. ! + ! ----------------------------------------------------------------- ! + if (excessm*excessn > 0._r8) then + xc = min(1._r8,max(0._r8,1._r8-2._r8*wa*gravit*cridis/wn**2._r8*(1._r8-thvn/thv_zm(k+1)))) + aquad = 0._r8 + bquad = 0._r8 + cquad = 0._r8 + else + ! -------------------------------------------------- ! + ! Case 2 : When either cumulus or env. is saturated. ! + ! -------------------------------------------------- ! + xsat = excessn / ( excessn - excessm ); + thlxsat = thln + xsat * ( thl_zm(k+1) - thln ); + qtxsat = qtn + xsat * ( qt_zm(k+1) - qtn ); + call condensation_mf(qtxsat, thlxsat, p_zm(k+1), iexner_zm(k+1), & + thvxsat, qcn, thn, qln, qin, qsn, lmixn) + ! -------------------------------------------------- ! + ! kk=1 : Cumulus Segment, kk=2 : Environment Segment ! + ! -------------------------------------------------- ! + do kk = 1, 2 + if( kk .eq. 1 ) then + thv_x0 = thvn + thv_x1 = ( 1._r8 - 1._r8/xsat ) * thvn + ( 1._r8/xsat ) * thvxsat + else + thv_x1 = thv_zm(k+1) + thv_x0 = ( xsat / ( xsat - 1._r8 ) ) * thv_zm(k+1) + ( 1._r8/( 1._r8 - xsat ) ) * thvxsat + endif + aquad = wn**2 + bquad = 2._r8*wa*gravit*cridis*(thv_x1 - thv_x0)/thv_zm(k+1) - 2._r8*wn**2 + cquad = 2._r8*wa*gravit*cridis*(thv_x0 - thv_zm(k+1))/thv_zm(k+1) + wn**2 + if( kk .eq. 1 ) then + if( ( bquad**2-4._r8*aquad*cquad ) .ge. 0._r8 ) then + call roots(aquad,bquad,cquad,xs1,xs2,status) + x_cu = min(1._r8,max(0._r8,min(xsat,min(xs1,xs2)))) + else + x_cu = xsat + endif + else + if( ( bquad**2-4._r8*aquad*cquad) .ge. 0._r8 ) then + call roots(aquad,bquad,cquad,xs1,xs2,status) + x_en = min(1._r8,max(0._r8,max(xsat,min(xs1,xs2)))) + else + x_en = 1._r8 + endif + endif + enddo + if( x_cu .eq. xsat ) then + xc = max(x_cu, x_en) + else + xc = x_cu + endif + endif + + ee2 = xc**2 + ud2 = 1._r8 - 2._r8*xc + xc**2 + + ! detrainment rate + detn = mix(k+1,i) * ud2 + + else !no bsort + ee2 = 1._r8 + ud2 = 1._r8 + end if + + ! entrainment rate + entn = mix(k+1,i) * ee2 + + ! --------------------------------------------------------- ! + ! TKE enhanced entrainment ! + ! switches off when dynamic_L0 > max_L0 ! + ! --------------------------------------------------------- ! + eturb = (1._r8 + clubb_mf_alphturb*sqrt(tke(k))/upw(k,i)) + if (do_clubb_mf_rhtke) then + rh_L0 = 50._r8*(rhinv**3._r8) + if (rh_L0 >= 733.34_r8) eturb = 1._r8 + else + if (dynamic_L0(i) >= clubb_mf_max_L0) eturb = 1._r8 + end if + entn = entn * eturb + + ! integrate updraft + entexp = exp(-entn*eturb*dzt(k+1)) + entexpu = exp(-entn*dzt(k+1)/3._r8) + + qtn = qt(k+1) *(1._r8-entexp ) + upqt (k,i)*entexp + supqt(k+1,i) + thln = thl(k+1)*(1._r8-entexp ) + upthl(k,i)*entexp + supthl(k+1,i) + un = u(k+1) *(1._r8-entexpu) + upu (k,i)*entexpu + vn = v(k+1) *(1._r8-entexpu) + upv (k,i)*entexpu + + ! convert source terms to a tendency (convert from S*dz/w to S) + supqt(k+1,i) = supqt(k+1,i)*upw(k,i)/dzt(k+1) + upauto(k+1,i) = supqt(k+1,i) + supthl(k+1,i) = supthl(k+1,i)*upw(k,i)/dzt(k+1) + + ! get cloud, momentum levels + if (do_condensation) then + call condensation_mf(qtn, thln, p_zm(k+1), iexner_zm(k+1), & + thvn, qcn, thn, qln, qin, qsn, lmixn) + if (zcb(i).eq.zcb_unset .and. qcn > 0._r8) zcb(i) = zm(k+1) + else + thvn = thln*(1._r8+zvir*qtn) + end if + + ! get buoyancy + B=gravit*(0.5_r8*(thvn + upthv(k,i))/thv(k+1)-1._r8) + + if (do_implicit) then + wp = clubb_mf_alphturb*wb*entn*sqrt(0.5_r8*(tke(k+1)+tke(k)))*dzt(k+1) + wn = (-wp + sqrt(wp**2._r8 + (1._r8 + 2._r8*wb*entn*dzt(k+1))* & + (upw(k,i)**2._r8 + 2._r8*wa*B*dzt(k+1))) )/(1._r8 + 2._r8*wb*entn*dzt(k+1)) + else + ! get wn2 + wp = wb*entn*eturb + if (wp==0._r8) then + wn2 = upw(k,i)**2._r8+2._r8*wa*B*dzt(k+1) + else + entw = exp(-2._r8*wp*dzt(k+1)) + wn2 = entw*upw(k,i)**2._r8+(1._r8-entw)*wa*B/wp + end if + wn = sqrt(max(wn2, 0._r8)) + end if + + end do !iter_xc + +!+++arh - limit convection to within troposphere + !if (wn>0._r8 .and. (k+1)0._r8) then + + upthv(k+1,i) = thvn + upthl(k+1,i) = thln + upqt(k+1,i) = qtn + upqc(k+1,i) = qcn + upqs(k+1,i) = qsn + upu(k+1,i) = un + upv(k+1,i) = vn + upql(k+1,i) = qln + upqi(k+1,i) = qin + upqv(k+1,i) = qtn - qcn + uplmix(k+1,i)= lmixn + upth(k+1,i) = thn + + if (bsort) then + mfn = upmf(k,i)*exp( dzt(k+1)*( entn - detn )) + upa(k+1,i) = mfn/(wn*rho_zm(k+1)) + else + upa(k+1,i) = upa(k,i) + mfn = rho_zm(k+1)*upa(k+1,i)*wn + detn = entn - (mfn - rho_zm(k)*upa(k,i)*upw(k,i)) & + /(rho_zm(k)*upa(k,i)*upw(k,i)*dzt(k+1)) + end if + + upbuoy(k+1,i)= B + upw(k+1,i) = wn + upmf(k+1,i) = mfn + upent(k+1,i) = entn + updet(k+1,i) = detn + + else + ! zero out plumes that terminate at k<3 + if ((k-kstart+1)<4) then + supqt(:,i) = 0._r8 + upauto(:,i)= 0._r8 + supthl(:,i)= 0._r8 + + upa(:,i) = 0._r8 + upbuoy(:,i)= 0._r8 + upw(:,i) = 0._r8 + upmf(:,i) = 0._r8 + upent(:,i) = 0._r8 + updet(:,i) = 0._r8 + + upthv(:,i) = 0._r8 + upthl(:,i) = 0._r8 + upqt(:,i) = 0._r8 + upqc(:,i) = 0._r8 + upqs(:,i) = 0._r8 + upu(:,i) = 0._r8 + upv(:,i) = 0._r8 + upql(:,i) = 0._r8 + upqi(:,i) = 0._r8 + upqv(:,i) = 0._r8 + uplmix(:,i)= 0._r8 + upth(:,i) = 0._r8 + end if + ! exit updraft integration + exit + ! + end if + enddo + enddo + + ! --------------------------------------------------------- ! + ! downward sweep for rain evaporation, snow melting ! + ! --------------------------------------------------------- ! + if (do_clubb_mf_precip) then + do i=1,clubb_mf_nup + do k=nz,2,-1 + ! get rain evaporation + if ((upqs(k,i) + upqs(k-1,i)).le.0._r8) then + qtovqs = 0._r8 + else + qtovqs = (upqt(k,i) + upqt(k-1,i))/(upqs(k,i) + upqs(k-1,i)) + end if + qtovqs = min(1._r8,qtovqs) + sevap = ke*(1._r8 - qtovqs)*sqrt(max(uprr(k,i),0._r8)) + + ! limit evaporation to available precip + sevap = min(sevap,( uprr(k,i)/(rho_zt(k)*dzt(k)) - supqt(k,i)*(1._r8-clubb_mf_fdd) )) + + ! get rain rate + uprr(k-1,i) = uprr(k,i) & + - rho_zt(k)*dzt(k)*( supqt(k,i)*(1._r8-clubb_mf_fdd) + sevap ) + + ! update source terms + lmixt = 0.5_r8*(uplmix(k,i)+uplmix(k-1,i)) + supqt(k,i) = supqt(k,i) + sevap + supthl(k,i) = supthl(k,i) - lmixt*sevap*iexner_zt(k)/cpair + end do + end do + end if + + ! --------------------------------------------------------- ! + ! begin computing downdrafts ! + ! --------------------------------------------------------- ! + if (do_clubb_mf_precip .and. clubb_mf_fdd > 0._r8) then + + do i=1,clubb_mf_nup + + ! find cloud base + do k = 1,nz + if (upqc(k,i) > 0._r8) then + ddbot(i) = k + exit + end if + end do + + ! find cloud top + ddtop = 0 + do k = 1,nz + if (uprr(k,i) > 0._r8) ddtop = k + end do + + if (ddtop /= 0) then + ! initilaize downdrafts + + ! Kay initializes using negative of the updraft velocity + ! this causes anomalouly large downdrafts at the initializaiton level + ! I am intializing with zero velocity as that is more physically defensible + dnw(ddtop,i) = -1._r8*mindnw !upw(ddtop,i) ! 0._r8 + dna(ddtop,i) = upa(ddtop,i) + dnu(ddtop,i) = 0.5_r8*(u(ddtop)+u(ddtop+1)) + dnv(ddtop,i) = 0.5_r8*(v(ddtop)+v(ddtop+1)) + dnqt(ddtop,i) = qt_zm(ddtop) + + ! no cloud in downdrafts, set to cloud free thl + dnthl(ddtop,i) = thl_zm(ddtop) + dnthv(ddtop,i) = thv_zm(ddtop) ! includes condensate loading (!) + + ! get rain generated in the updraft, appropriate it to the downdraft + dnrr(ddtop,i) = -1._r8*dzt(ddtop)*rho_zt(ddtop)*upauto(ddtop,i)*clubb_mf_fdd + + if (fixent) then + entn = fixent_ent + else + ! use deterministic mean entrainment + entn = clubb_mf_ent0/dynamic_L0(i) + end if + + ! downdraft qsat + call qsat(dnthl(ddtop,i)/iexner_zm(ddtop),p_zm(ddtop),es,dnqs(ddtop,i)) + + do k = ddtop-1,1,-1 + + ! assume fixed area with height + dna(k,i) = dna(k+1,i) + + ! get rain evaporation in integrated form + taum1 = ke*sqrt(dnrr(k+1,i))/dnqs(k+1,i) + alphint = exp(dzt(k+1)*taum1/dnw(k+1,i)) + sqtint = max( (dnqs(k+1,i) - dnqt(k+1,i))*(1._r8 - alphint) ,0._r8) + + ! limit to available rain + sqtint = min( sqtint, -1._r8*dnrr(k+1,i) / (rho_zt(k+1)*dzt(k+1)*dnw(k+1,i)) ) + sthlint = -1._r8*latvap*sqtint*iexner_zt(k+1)/cpair + + ! get rain evaporation in tendency form + sdnqt(k,i) = max( (dnqs(k+1,i) - dnqt(k+1,i))*taum1, 0._r8 ) + sdnthl(k,i) = -1._r8*latvap*sdnqt(k,i)*iexner_zt(k+1)/cpair + + ! compute rain rate (rain above - evaporation + appropriate updraft rain) + dnrr(k,i) = max( dnrr(k+1,i) & + - rho_zt(k+1)*dzt(k+1)*(sdnqt(k,i) + upauto(k+1,i)*clubb_mf_fdd) , 0._r8 ) + + ! include eturb? + entexp = exp(-1._r8*entn*eturb*dzt(k+1)) + entexpu = exp(-1._r8*entn*dzt(k+1)/3._r8) + + ! integrate downward + dnu(k,i) = u(k+1) *(1._r8-entexpu) + dnu (k+1,i)*entexpu + dnv(k,i) = v(k+1) *(1._r8-entexpu) + dnv (k+1,i)*entexpu + dnqt(k,i) = qt(k+1) *(1._r8-entexp ) + dnqt (k+1,i)*entexp + sqtint + dnthl(k,i) = thl(k+1)*(1._r8-entexp ) + dnthl(k+1,i)*entexp + sthlint + + ! get qsat + call qsat(dnthl(k,i)/iexner_zm(k),p_zm(k),es,dnqs(k,i)) + + ! no supersaturation in downdrafts + if (dnqt(k,i) > dnqs(k,i)) then + ! set qt to saturation vapor pressure + dnqt(k,i) = dnqs(k,i) + + ! find evaporation that gives saturation vapor pressure + sqtint = dnqt(k,i) - (qt(k+1) *(1._r8-entexp ) + dnqt (k+1,i)*entexp) + + ! limit to available rain + sqtint = min( sqtint, -1._r8*dnrr(k+1,i) / (rho_zt(k+1)*dzt(k+1)*dnw(k+1,i)) ) + sthlint = -1._r8*latvap*sqtint*iexner_zt(k+1)/cpair + + ! find new evap tendency + if ((alphint - 1._r8) /= 0._r8) then + qtmp = dnqs(k+1,i) + sqtint/(alphint - 1._r8) + sdnqt(k,i) = max( (dnqs(k+1,i) - qtmp)*taum1, 0._r8 ) + else + sdnqt(k,i) = 0._r8 + end if + sdnthl(k,i) = -1._r8*latvap*sdnqt(k,i)*iexner_zt(k+1)/cpair + + ! re-compute thl with new evaporation rate + dnthl(k,i) = thl(k+1)*(1._r8-entexp ) + dnthl(k+1,i)*entexp + sthlint + + ! adjust rain + dnrr(k,i) = max( dnrr(k+1,i) & + - rho_zt(k+1)*dzt(k+1)*(sdnqt(k,i) + upauto(k+1,i)*clubb_mf_fdd) , 0._r8 ) + end if + + ! get virtual temperature + dnthv(k,i) = dnthl(k,i)*(1._r8+zvir*dnqt(k,i)) + + if (k > ddbot(i)) then + ! get virtual temperature + dnthv(k,i) = dnthl(k,i)*(1._r8+zvir*dnqt(k,i)) + + ! get buoyancy + ! (midpoint k is surrounded by interface k and k-1, + ! and therefore we can't compute B at the midpoint properly) + B = gravit*(dnthv(k,i)/thv(k)-1._r8) + + ! get wn2 + wp = wb*entn*eturb & + + clubb_mf_pwfac/( 2._r8*zm(k)+tinynum ) * max( 1._r8 - exp( zm(k)/z00dn-1._r8), 0._r8 ) + if (wp==0._r8) then + wn2 = dnw(k+1,i)**2._r8-2._r8*wa*B*dzt(k+1) + else + entw = exp(-2._r8*wp*dzt(k+1)) + wn2 = entw*dnw(k+1,i)**2._r8-(1._r8-entw)*wa*B/wp + end if + wn2 = max(wn2,mindnw**2._r8) + dnw(k,i) = -1._r8*sqrt(wn2) + + ! enforce net positive mass flux at cloud base + !if (k == (ddbot(i)+1)) then + ! if (sqrt(wn2) > upw(k,i)) dnw(k,i) = -1._r8*upw(k,i) + !end if + + else + zsub = zm(ddbot(i)+1) + wcb = dnw(ddbot(i)+1,i) + dnw(k,i) = wcb - (wcb/(zsub**clubb_mf_ddexp))*(zsub - zm(k))**clubb_mf_ddexp + dnw(k,i) = min(dnw(k,i),-1._r8*mindnw) + end if + + end do!k + + end if + + end do!i + +!+++ARH this should be changed to only zero out above the downdraft (dnw<-mindw) +!+++ARH also this should zero out dna as well + ! zero out downdraft fluxes for dnw == -mindnw + do i=1,clubb_mf_nup + do k=1,nz + if ( dnw(k,i) == -1._r8*mindnw ) then + dnw(k,i) = 0._r8 + dna(k,i) = 0._r8 + end if + end do + end do + + end if + ! end computing downdrafts + + ! --------------------------------------------------------- ! + ! AS.pd limiter ! + ! --------------------------------------------------------- ! + if (do_aspd) then + do k=1,nz-1 + do i=1,clubb_mf_nup + if (upw(k+1,i)>0._r8) then + ! diagnose detrainment + Mn = rho_zm(k)*upa(k,i)*upw(k,i) + det = upent(k+1,i)*eturb - (rho_zm(k+1)*upa(k+1,i)*upw(k+1,i) - Mn) & + /(Mn*dzt(k+1)) + if (det < 0._r8) then + ! diagnose area to eliminate detrainment and conserve mass + Mn = rho_zm(k)*upa(k,i)*upw(k,i)*exp(upent(k+1,i)*eturb*dzt(k+1)) + upa(k+1,i) = Mn/(rho_zm(k+1)*upw(k+1,i)) + end if + ! + end if + end do + end do + end if + + ! --------------------------------------------------------- ! + ! integrate for total convective area ! + ! --------------------------------------------------------- ! + do k=1,nz-1 + ! + do i=1,clubb_mf_nup + aup(k) = aup(k) + upa(k,i) + adn(k) = adn(k) + dna(k,i) + end do + ac(k) = aup(k) + adn(k) + ! + if (limarea .and. ac(k) > amax) then + upa(k,:) = upa(k,:)*amax/ac(k) + ac(k) = amax + end if + ae(k) = ae(k) - ac(k) + ! + end do + + ! --------------------------------------------------------- ! + ! updraft properties for output ! + ! --------------------------------------------------------- ! + do k=1,nz + + ! first sum over all i-updrafts + do i=1,clubb_mf_nup + if (upqc(k,i)>0._r8) then + moist_a(k) = moist_a(k) + upa(k,i) + moist_w(k) = moist_w(k) + upa(k,i)*upw(k,i) + moist_qt(k) = moist_qt(k) + upa(k,i)*upqt(k,i) + moist_thl(k) = moist_thl(k) + upa(k,i)*upthl(k,i) + moist_u(k) = moist_u(k) + upa(k,i)*upu(k,i) + moist_v(k) = moist_v(k) + upa(k,i)*upv(k,i) + moist_qc(k) = moist_qc(k) + upa(k,i)*upqc(k,i) + else + dry_a(k) = dry_a(k) + upa(k,i) + dry_w(k) = dry_w(k) + upa(k,i)*upw(k,i) + dry_qt(k) = dry_qt(k) + upa(k,i)*upqt(k,i) + dry_thl(k) = dry_thl(k) + upa(k,i)*upthl(k,i) + dry_u(k) = dry_u(k) + upa(k,i)*upu(k,i) + dry_v(k) = dry_v(k) + upa(k,i)*upv(k,i) + endif + enddo + + if ( dry_a(k) > 0._r8 ) then + dry_w(k) = dry_w(k) / dry_a(k) + dry_qt(k) = dry_qt(k) / dry_a(k) + dry_thl(k) = dry_thl(k) / dry_a(k) + dry_u(k) = dry_u(k) / dry_a(k) + dry_v(k) = dry_v(k) / dry_a(k) + else + dry_w(k) = 0._r8 + dry_qt(k) = 0._r8 + dry_thl(k) = 0._r8 + dry_u(k) = 0._r8 + dry_v(k) = 0._r8 + endif + + if ( moist_a(k) > 0._r8 ) then + moist_w(k) = moist_w(k) / moist_a(k) + moist_qt(k) = moist_qt(k) / moist_a(k) + moist_thl(k) = moist_thl(k) / moist_a(k) + moist_u(k) = moist_u(k) / moist_a(k) + moist_v(k) = moist_v(k) / moist_a(k) + moist_qc(k) = moist_qc(k) / moist_a(k) + else + moist_w(k) = 0._r8 + moist_qt(k) = 0._r8 + moist_thl(k) = 0._r8 + moist_u(k) = 0._r8 + moist_v(k) = 0._r8 + moist_qc(k) = 0._r8 + endif + + enddo + + ! --------------------------------------------------------- ! + ! get ensemble mean ! + ! --------------------------------------------------------- ! + do k=1,nz + do i=1,clubb_mf_nup + + awup(k) = awup(k) + upa(k,i)*upw(k,i) + awdn(k) = awdn(k) + dna(k,i)*dnw(k,i) + + awwup(k) = awwup(k) + upa(k,i)*upw(k,i)*upw(k,i) + awwdn(k) = awwdn(k) + dna(k,i)*dnw(k,i)*dnw(k,i) + + awuup(k) = awuup(k) + upa(k,i)*upw(k,i)*upu(k,i) + awudn(k) = awudn(k) + dna(k,i)*dnw(k,i)*dnu(k,i) + awvup(k) = awvup(k) + upa(k,i)*upw(k,i)*upv(k,i) + awvdn(k) = awvdn(k) + dna(k,i)*dnw(k,i)*dnv(k,i) + + awthvdn(k)= awthvdn(k)+ dna(k,i)*dnw(k,i)*dnthv(k,i) + awthldn(k)= awthldn(k)+ dna(k,i)*dnw(k,i)*dnthl(k,i) + awqtdn(k) = awqtdn(k) + dna(k,i)*dnw(k,i)*dnqt(k,i) + + awthvup(k)= awthvup(k)+ upa(k,i)*upw(k,i)*upthv(k,i) + awthlup(k)= awthlup(k)+ upa(k,i)*upw(k,i)*upthl(k,i) + awqtup(k) = awqtup(k) + upa(k,i)*upw(k,i)*upqt(k,i) + + if (k > 1) then + sqtup(k) = sqtup(k) + upa(k-1,i)*supqt(k,i) + sthlup(k) = sthlup(k) + upa(k-1,i)*supthl(k,i) + + sqtdn(k) = sqtdn(k) + dna(k,i)*sdnqt(k,i) + sthldn(k) = sthldn(k) + dna(k,i)*sdnthl(k,i) + end if + + enddo + + aw (k) = awup(k)+ awdn(k) + aww(k) = awwup(k)+ awwdn(k) +!+++arh + !awu(k) = awuup(k)+ awudn(k) + if (aloft) awu(k) = 1._r8 + + awv(k) = awvup(k)+ awvdn(k) + sqt(k) = sqtup(k) + sqtdn(k) + sthl(k)= sthlup(k) + sthldn(k) + + enddo + + ! --------------------------------------------------------- ! + ! ztopm1 calculation ! + ! --------------------------------------------------------- ! + do i=1,clubb_mf_nup + do k=kstart,nz + ! return if no convection at k=2 + if (k == 2 .and. ac(k) == 0._r8 .and. .not.aloft) then + sqt(k) = 0._r8 + sthl(k) = 0._r8 + ztopm1(:) = zm(1) + ddcp(:) = 0._r8 + return + end if + ! height of the plume ensemble + if (do_clubb_mf_lscale_perplume) then + if ((upa(k,i)+dna(k,i)) > 0._r8) ztopm1(i) = zm(k) + else + if (ac(k) > 0._r8) ztopm1(:) = zm(k) + end if + end do + end do + + !subtract init level from ztop for aloft plumes + if (aloft) then + ztopm1 = ztopm1 - zm(kstart-nbot) + do i=1,clubb_mf_nup + if (ztopm1(i) < zm(1)) ztopm1(i) = zm(1) + end do + end if + + ! --------------------------------------------------------- ! + ! cloud base / mixing depth calculation ! + ! --------------------------------------------------------- ! + cbm1 = 0._r8 + do i=1,clubb_mf_nup + kcbarr(i) = 0 + do k=kstart,nz + if (upqc(k,i) > 0._r8) then + kcbarr(i) = k + exit + end if + end do + + ! find height of dry plumes + if (kcbarr(i) == 0) then + do k=kstart,nz + if (upw(k,i) <= 0._r8) then + kcbarr(i) = k + exit + end if + end do + end if + + cbm1 = cbm1 + zm(kcbarr(i)) + + end do + cbm1 = cbm1/REAL(clubb_mf_nup) + + ! --------------------------------------------------------- ! + ! bulk downdraft velocity for coldpool parameterization ! + ! --------------------------------------------------------- ! +!+++ARH +! ! reset ddcp +! ddcp = 0._r8 +! do i=1,clubb_mf_nup +! ! find cloud base +! kcb = 0 +! do k=1,nz +! if (upqc(k,i) > 0._r8) then +! kcb = k +! exit +! end if +! end do +! +! ! reset iddcp +! iddcp = 0._r8 +! if (kcb == 0) then +! continue +! else if (kcb == 1) then +! iddcp = iddcp + dna(k,i)*dnw(k,i) +! continue +! else +! ddint = 0._r8 +! do k=1,kcb-1 +! ddint = ddint + dna(k,i)*dnw(k,i)*dzt(k+1) +! end do +! iddcp = iddcp + -1._r8*ddint/zm(kcb) +! end if +! ddcp = ddcp + iddcp +! ! +! end do +! + + ddcp(:) = 0._r8 + if (do_clubb_mf_coldpool .and. clubb_mf_fdd > 0._r8) then + ! use single level for cold pool param. + ! reset ddcp + do i=1,clubb_mf_nup + if (ddbot(i) == 0) then + continue + else + if (do_clubb_mf_coldpool_perplume) then + ddcp(i) = -1._r8*dnw(ddbot(i)+1,i) + else + ddcp(:) = ddcp(:) + -1._r8*dna(ddbot(i)+1,i)*dnw(ddbot(i)+1,i) + end if + end if + end do + ! + end if +!---ARH + + ! --------------------------------------------------------- ! + ! downward sweep to get ensemble mean precip ! + ! --------------------------------------------------------- ! + do k = nz,2,-1 + precc(k-1) = precc(k) - rho_zt(k)*dzt(k)*sqt(k) + end do + + ! --------------------------------------------------------- ! + ! get turbulent fluxes ! + ! --------------------------------------------------------- ! + thv_env = thv + thl_env = thl + qt_env = qt + + betathl = (thl_env(4)-thl_env(2))/(0.5_r8*(dzt(4)+2._r8*dzt(3)+dzt(2))) + betaqt = (qt_env(4)-qt_env(2))/(0.5_r8*(dzt(4)+2._r8*dzt(3)+dzt(2))) + + thl_env(1) = thl_env(2)-betathl*0.5_r8*(dzt(2)+dzt(1)) + qt_env(1) = qt_env(2)-betaqt*0.5_r8*(dzt(2)+dzt(1)) + if (qt_env(1) < 0._r8) qt_env(1) = 0._r8 + + kstart = 2 + if (scalesrf) then + kstart = 1 + end if + + do k=kstart,nz-1 + thvflxup(k)= awthvup(k) - awup(k)*thv_env(k+1) + thlflxup(k)= awthlup(k) - awup(k)*thl_env(k+1) + qtflxup (k)= awqtup (k) - awup(k)*qt_env (k+1) + + uflxup (k)= awuup(k) - awup(k)*u(k+1) + vflxup (k)= awvup(k) - awup(k)*v(k+1) + + ! if no downdrafts, should be zero since awdn should be zero + thvflxdn(k)= awthvdn(k) - awdn(k)*thv_env(k) + thlflxdn(k)= awthldn(k) - awdn(k)*thl_env(k) + qtflxdn (k)= awqtdn (k) - awdn(k)*qt_env (k) + + uflxdn (k)= awudn(k) - awdn(k)*u(k) + vflxdn (k)= awvdn(k) - awdn(k)*v(k) + + thvflx(k) = thvflxup(k) + thvflxdn(k) + thlflx(k) = thlflxup(k) + thlflxdn(k) + qtflx (k) = qtflxup (k) + qtflxdn (k) + + uflx(k) = uflxup(k) + uflxdn(k) + vflx(k) = vflxup(k) + vflxdn(k) + enddo + ! + else + ddcp(:) = 0._r8 + ztopm1(:) = zm(1) + end if ! ( wthv > 0.0 ) + + end subroutine integrate_mf + + subroutine get_Lscale(nz, zm, tke, wpthlp_env, dzt, iexner_zm, iexner_zt, p_zm, qt, thv, thl, th, & + wmax, wmin, sigmaw, sigmaqt, sigmathv, cwqt, cwthv, zcb_unset, wa, wb, & + do_condensation, qv, p_zt, zt, tpert, pblh, convh, rhinv, ztopm1, dynamic_L0, ztop, mcape) + ! --------------------------------------------------------- ! + ! Calculate ztop and dynamic_L based on value of namelist ! + ! --------------------------------------------------------- ! + integer, intent(in) :: nz + real(r8), dimension(nz), intent(in) :: thl, thv, & + th, & + qt, qv, & + p_zt, iexner_zt, & + dzt, zt, & + p_zm, iexner_zm, & + zm, & + tke, wpthlp_env + ! + real(r8), intent(in) :: wmax, wmin, tpert, & + sigmaw, sigmaqt, sigmathv, & + cwqt, cwthv, zcb_unset, & + wa, wb, ztopm1, & + pblh, convh, rhinv + ! + logical, intent(in) :: do_condensation + ! + real(r8), intent(out) :: dynamic_L0, ztop, mcape + ! + ! local variables + real(r8), dimension(nz) :: t_zt + real(r8), dimension(nz-1) :: tp, qstp + !real(r8), dimension(nz-1,clubb_mf_nup) :: dmpdz + !real(r8), dimension(clubb_mf_nup) :: tl, & + ! cape, cin + !integer, dimension(clubb_mf_nup) :: lcl, lel + real(r8), dimension(nz-1,1) :: dmpdz + real(r8), dimension(1) :: tl, & + cape, cin + integer, dimension(1) :: lcl, lel + real(r8) :: landfrac + integer :: kpbl, msg, & + lon, mx, & + k + + ! intialize local variables + cape = 0._r8 + mcape = 0._r8 + dmpdz = 0._r8 + + if (clubb_mf_Lopt==0) then + !Constant L0 + dynamic_L0 = clubb_mf_L0 + ztop = clubb_mf_L0 + else if (clubb_mf_Lopt==1) then + !TKE + do k=nz-2,2,-1 + if (zm(k) < 20000 .and. tke(k) - tke(k+1) > 1e-5) then + ztop = zm(k) + exit + endif + enddo + dynamic_L0 = clubb_mf_a0*(ztop**clubb_mf_b0) + + else if (clubb_mf_Lopt==2) then + !Heat flux + do k=nz-2,2,-1 + !if (zm(k) < 20000 .and. abs(abs(wpthlp_env(k))-abs(wpthlp_env(k-1))) > 1e-3) then + if (zm(k) < 20000 .and. abs(abs(wpthlp_env(k))-abs(wpthlp_env(k-1))) > 1e-4) then + ztop = zm(k) + exit + endif + enddo + dynamic_L0 = clubb_mf_a0*(ztop**clubb_mf_b0) + + else if (clubb_mf_Lopt==3) then + !Test plume + call oneplume( nz, zm, dzt, iexner_zm, iexner_zt, p_zm, qt, thv, thl, & + wmax, wmin, sigmaw, sigmaqt, sigmathv, cwqt, cwthv, zcb_unset, & + wa, wb, tke, do_condensation, do_clubb_mf_precip, ztop ) + + dynamic_L0 = clubb_mf_a0*(ztop**clubb_mf_b0) + !ztop = ztop - 1600._r8 + !if (ztop < 1._r8) then + ! dynamic_L0 = clubb_mf_a0 + !else + ! dynamic_L0 = min(35._r8,clubb_mf_a0*(ztop**clubb_mf_b0)) + !end if + else if (clubb_mf_Lopt==4 .or. clubb_mf_Lopt==5) then + !dilute cape calculation + !dmpdz = -1._r8*ent_zt(2:nz,:) + dmpdz(:,:) = -1.E-3_r8 + t_zt = th/iexner_zt + landfrac = 1._r8 + + do k=2,nz + if (zt(k-1) <= pblh) then + kpbl = k + end if + end do + + do k=1,nz + if (p_zt(k) > 40.e2_r8) then + msg = k + end if + end do + !call buoyan_dilute(nz-1 ,clubb_mf_nup ,dmpdz , & + call buoyan_dilute(nz-1 ,1 ,dmpdz , & + qv(2:nz) ,t_zt(2:nz) ,p_zt(2:nz)*0.01_r8 ,zt(2:nz) ,p_zm*0.01_r8 , & + tp ,qstp ,tl ,cape ,cin , & + kpbl-1 ,lcl ,lel ,lon ,mx , & + msg-1 ,tpert ,landfrac ) + + !do i=1,clubb_mf_nup + ! mcape = mcape + cape(i) + !end do + !mcape = mcape/REAL(clubb_mf_nup) + mcape = max(cape(1),25._r8) + + if (clubb_mf_Lopt==4) then + ztop = max(zt(lel(1)+1),convh) + else if (clubb_mf_Lopt==5) then + ztop = mcape + end if + dynamic_L0 = clubb_mf_a0*(ztop**clubb_mf_b0) + + else if (clubb_mf_Lopt==6) then + ! grab ztop from max height of ensemble in prior time-step(s) + ztop = ztopm1 + dynamic_L0 = clubb_mf_a0*(ztop**clubb_mf_b0) + !if (masterproc) write(iam+110,*) 'mf_ztop, dynamic_L0 ', ztop, dynamic_L0 + else if (clubb_mf_Lopt==7 .or. clubb_mf_Lopt==8) then + ztop = rhinv + dynamic_L0 = clubb_mf_a0*(ztop**clubb_mf_b0) + end if + + end subroutine get_Lscale + + subroutine condensation_mf( qt, thl, p, iex, thv, qc, th, ql, qi, qs, lmix ) + ! =============================================================================== ! + ! zero or one condensation for edmf: calculates thv and qc ! + ! =============================================================================== ! + use physconst, only: cpair, zvir, h2otrip + use wv_saturation, only : qsat + + real(r8),intent(in) :: qt,thl,p,iex + real(r8),intent(out):: thv,qc,th,ql,qi,qs,lmix + + !local variables + integer :: niter,i + real(r8) :: diff,t,qstmp,qcold,es,wf + logical :: noice = .true. + + ! max number of iterations + niter=50 + ! minimum difference + diff=2.e-5_r8 + + qc=0._r8 + t=thl/iex + + !by definition: + ! T = Th*Exner, Exner=(p/p0)^(R/cp) (1) + ! Thl = Th - L/cp*ql/Exner (2) + !so: + ! Th = Thl + L/cp*ql/Exner (3) + ! T = Th*Exner=(Thl+L/cp*ql/Exner)*Exner (4) + ! = Thl*Exner + L/cp*ql + do i=1,niter + + if (noice) then + wf = 1._r8 + else + wf = get_watf(t) + end if + t = thl/iex+get_alhl(wf)/cpair*qc !as in (4) + + ! qsat, p is in pascal (check!) + call qsat(t,p,es,qstmp) + qcold = qc + qc = max(0.5_r8*qc+0.5_r8*(qt-qstmp),0._r8) + if (abs(qc-qcold)tmax) then + get_watf=1._r8 + else if (tc qstar) then + ! get precip efficiency + tauwgt = (dzcld-zmin)/(zmax-zmin) + tauwgt = min(max(tauwgt,0._r8),1._r8) + tau = tauwgt/tau0 + + ! get source for updraft + Supqt = (qstar-qt)*(1._r8 - exp(-1._r8*tau*dz/w)) + else + Supqt = 0._r8 + end if + + end subroutine precip_mf + + subroutine poisson(nz,nup,lambda,poi,state) + !********************************************************************** + ! Set a unique (but reproduceble) seed for the kiss RNG + ! Call Poisson deviate + ! By Adam Herrington + !********************************************************************** + use shr_RandNum_mod, only: ShrKissRandGen + + integer, intent(in) :: nz,nup + real(r8), dimension(4), intent(in) :: state + real(r8), dimension(nz,nup), intent(in) :: lambda + integer, dimension(nz,nup), intent(out) :: poi + integer, dimension(1,4) :: tmpseed + integer :: i,j + type(ShrKissRandGen) :: kiss_gen + + ! Compute seed + tmpseed(1,1) = int((state(1) - int(state(1))) * 1000000000._r8) + tmpseed(1,2) = int((state(2) - int(state(2))) * 1000000000._r8) + tmpseed(1,3) = int((state(3) - int(state(3))) * 1000000000._r8) + tmpseed(1,4) = int((state(4) - int(state(4))) * 1000000000._r8) + + ! Set seed + kiss_gen = ShrKissRandGen(tmpseed) + + do i=1,nz + do j=1,nup + call hybridRNG(kiss_gen,lambda(i,j),poi(i,j)) + enddo + enddo + + end subroutine poisson + + subroutine hybridRNG(kiss_gen,lambda,kout) + !********************************************************************** + ! Interface for the two poisson rng subroutines + ! chooses the appropriate subroutine based on the value of lambda + !********************************************************************** + use shr_RandNum_mod, only: ShrKissRandGen + + type(ShrKissRandGen), intent(inout) :: kiss_gen + real(r8), intent(in) :: lambda + integer, intent(out) :: kout + + if (lambda < 10._r8) then + call knuth(kiss_gen,lambda,kout) + else + call hormann(kiss_gen,lambda,kout) + end if + + end subroutine hybridRNG + + subroutine knuth(kiss_gen,lambda,kout) + !********************************************************************** + ! Discrete random poisson from Knuth + ! The Art of Computer Programming, v2, 137-138 + ! By Adam Herrington + !********************************************************************** + use shr_RandNum_mod, only: ShrKissRandGen + + type(ShrKissRandGen), intent(inout) :: kiss_gen + real(r8), intent(in) :: lambda + integer, intent(out) :: kout + + ! Local variables + real(r8), dimension(1,1) :: tmpuni + real(r8) :: puni, explam + integer :: k + + k = 0 + explam = exp(-1._r8*lambda) + puni = 1._r8 + do while (puni > explam) + k = k + 1 + call kiss_gen%random(tmpuni) + puni = puni*tmpuni(1,1) + end do + kout = k - 1 + + end subroutine knuth + + subroutine hormann(kiss_gen,lambda,kout) + !********************************************************************** + ! Discrete random poisson + ! Implements Poisson Transformed Rejection with Squeeze (PTRS) + ! from W. Hormann Insurance: Mathematics and Economics 12, 39-45 (1993) + ! By Jake Reschke + !********************************************************************** + use shr_RandNum_mod, only: ShrKissRandGen + + type(ShrKissRandGen), intent(inout) :: kiss_gen + real(r8), intent(in) :: lambda + integer, intent(out) :: kout + + ! Local variables + real(r8), dimension(1,1) :: U,V + real(r8) :: a,b,vr,alphinv,us,loggam + integer :: k,i + + b = 0.931_r8 + 2.53_r8*sqrt(lambda) + a = -0.059_r8 + 0.02483_r8*b + vr = 0.9277_r8 - 3.6224_r8/(b - 2._r8) + alphinv = 1.1239_r8 + 1.1328_r8/(b - 3.4_r8) + + do + call kiss_gen%random(U) + call kiss_gen%random(V) + U(1,1) = U(1,1) - 0.5_r8 + us = 0.5_r8 - abs(U(1,1)) + k = floor( (2._r8*a/us + b)*U(1,1) + lambda + 0.43_r8 ) + if (us >= 0.07_r8 .and. V(1,1) <= vr) then + kout = k + exit + end if + if (k <= 0 .or. (us < 0.013_r8 .and. V(1,1) > us)) then + cycle + end if + ! compute log(k!). If k >=10 use stirling's approximation + if (k < 10) then + loggam = 0._r8 + do i = 1, k + loggam = loggam + log(1._r8*i) + end do + else + loggam = log(sqrt(2._r8*pi)) + (k + 0.5_r8)*log(1._r8*k) - k + (1._r8/12._r8 - 1._r8/(360._r8*k*k))/k + end if + if (log( V(1,1)*alphinv/(a/(us*us) + b) ) <= -1._r8*lambda + k*log(lambda) - loggam) then + kout = k + exit + end if + end do + + end subroutine hormann + + subroutine roots(a,b,c,r1,r2,status) + ! --------------------------------------------------------- ! + ! Subroutine to solve the second order polynomial equation. ! + ! after uwshcu.F90 ! + ! --------------------------------------------------------- ! + real(r8), intent(in) :: a + real(r8), intent(in) :: b + real(r8), intent(in) :: c + real(r8), intent(out) :: r1 + real(r8), intent(out) :: r2 + integer , intent(out) :: status + real(r8) :: q + + status = 0 + + if( a .eq. 0._r8 ) then ! Form b*x + c = 0 + if( b .eq. 0._r8 ) then ! Failure: c = 0 + status = 1 + else ! b*x + c = 0 + r1 = -c/b + endif + r2 = r1 + else + if( b .eq. 0._r8 ) then ! Form a*x**2 + c = 0 + if( a*c .gt. 0._r8 ) then ! Failure: x**2 = -c/a < 0 + status = 2 + else ! x**2 = -c/a + r1 = sqrt(-c/a) + endif + r2 = -r1 + else ! Form a*x**2 + b*x + c = 0 + if( (b**2 - 4._r8*a*c) .lt. 0._r8 ) then ! Failure, no real roots + status = 3 + else + q = -0.5_r8*(b + sign(1.0_r8,b)*sqrt(b**2 - 4._r8*a*c)) + r1 = q/a + r2 = c/q + endif + endif + endif + + return + + end subroutine roots + + subroutine oneplume( nz, zm, dzt, iexner_zm, iexner_zt, p_zm, qt, thv, thl, & + wmax, wmin, sigmaw, sigmaqt, sigmathv, cwqt, cwthv, zcb_unset, & + wa, wb, tke, do_condensation, do_precip, plumeheight ) + !********************************************************************** + ! Calculate a single plume with fixed entrainment + ! to be used for a dynamic mixing length calculation + ! By Rachel Storer + !********************************************************************** + use physconst, only: cpair, gravit, zvir + + integer, intent(in) :: nz + real(r8), dimension(nz), intent(in) :: zm, dzt, iexner_zm, iexner_zt, & + p_zm, qt, thv, thl, tke + real(r8), intent(in) :: wmax, wmin, sigmaw, sigmaqt, sigmathv, cwqt, & + cwthv, zcb_unset, wa, wb + logical, intent(in) :: do_condensation, do_precip + + real(r8), intent(inout) :: plumeheight + + !local variables + integer :: k + real(r8) :: thvn, qtn, thln, qcn, thn, qln, qin, qsn, lmixn, zcb, B, wn2, pentexp, pturb, pentw, wp + real(r8), dimension(nz) :: upw, upa, upqt, upthv, upthl, upth, upqs, & + upqc, upql, upqi, supqt, supthl + ! + ! fractional entrainment rate + real(r8), parameter :: pent = 1.E-3_r8 + ! + ! use tke enhanced entrainment + logical :: do_tptke = .false. + + zcb = zcb_unset + + upw(1) = 0.5_r8 * wmax + upa(1) = 0.5_r8 * erf( wmax/(sqrt(2._r8)*sigmaw) ) + + upqt(1) = cwqt * upw(1) * sigmaqt/sigmaw + upthv(1) = cwthv * upw(1) * sigmathv/sigmaw + + upqt(1) = qt(1)+upqt(1) + upthv(1) = thv(1)+upthv(1) + upthl(1) = upthv(1) / (1._r8+zvir*upqt(1)) + upth(1) = upthl(1) + + ! get cloud, lowest momentum level + if (do_condensation) then + call condensation_mf(upqt(1), upthl(1), p_zm(1), iexner_zm(1), & + thvn, qcn, thn, qln, qin, qsn, lmixn) + upthv(1) = thvn + upqc(1) = qcn + upql(1) = qln + upqi(1) = qin + upqs(1) = qsn + upth(1) = thn + if (qcn > 0._r8) zcb = zm(1) + else + ! assume no cldliq + upqc(1) = 0._r8 + end if + + do k=1,nz-1 + ! get microphysics, autoconversion + if (do_precip .and. upqc(k) > 0._r8) then + call precip_mf(upqs(k),upqt(k),upw(k),dzt(k+1),zm(k+1)-zcb,supqt(k+1)) + supthl(k+1) = -1._r8*lmixn*supqt(k+1)*iexner_zt(k+1)/cpair + else + supqt(k+1) = 0._r8 + supthl(k+1) = 0._r8 + end if + ! integrate updraft + if (do_tptke) then + pturb = (1._r8 + clubb_mf_alphturb*sqrt(tke(k))/upw(k)) + else + pturb = 1._r8 + end if + pentexp = exp(-pent*pturb*dzt(k+1)) + qtn = qt(k+1) *(1._r8-pentexp ) + upqt (k)*pentexp + supqt(k+1) + thln = thl(k+1)*(1._r8-pentexp ) + upthl(k)*pentexp + supthl(k+1) + + ! convert source terms to a tendency + supqt(k+1) = supqt(k+1)*upw(k)/dzt(k+1) + supthl(k+1) = supthl(k+1)*upw(k)/dzt(k+1) + + ! get cloud, momentum levels + if (do_condensation) then + call condensation_mf(qtn, thln, p_zm(k+1), iexner_zm(k+1), & + thvn, qcn, thn, qln, qin, qsn, lmixn) + if (zcb.eq.zcb_unset .and. qcn > 0._r8) zcb = zm(k+1) + else + thvn = thln*(1._r8+zvir*qtn) + end if + ! get buoyancy + B=gravit*(0.5_r8*(thvn + upthv(k))/thv(k+1)-1._r8) + + ! get wn^2 + wp = wb*pent*pturb + if (wp==0._r8) then + wn2 = upw(k)**2._r8+2._r8*wa*B*dzt(k+1) + else + pentw = exp(-2._r8*wp*dzt(k+1)) + wn2 = pentw*upw(k)**2._r8+(1._r8-pentw)*wa*B/wp + end if + + if (wn2>0._r8) then + upw(k+1) = sqrt(wn2) + upthv(k+1) = thvn + upthl(k+1) = thln + upqt(k+1) = qtn + upqc(k+1) = qcn + upqs(k+1) = qsn + upa(k+1) = upa(k) + upql(k+1) = qln + upqi(k+1) = qin + upth(k+1) = thn + else + plumeheight = zm(k) + exit + end if + enddo + + end subroutine oneplume + +subroutine buoyan_dilute( nz ,nup ,dmpdz , & + q ,t ,p ,z ,pf , & + tp ,qstp ,tl ,cape ,cin , & + pblt ,lcl ,lel ,lon ,mx , & + msg ,tpert ,landfrac ) +!----------------------------------------------------------------------- +! +! Purpose: +! Calculates CAPE the lifting condensation level and the convective top +! where buoyancy is first -ve. +! +! Method: Calculates the parcel temperature based on a simple constant +! entraining plume model. CAPE is integrated from buoyancy. +! 09/09/04 - Simplest approach using an assumed entrainment rate for +! testing (dmpdp). +! 08/04/05 - Swap to convert dmpdz to dmpdp +! +! SCAM Logical Switches - DILUTE:RBN - Now Disabled +! --------------------- +! switch(1) = .T. - Uses the dilute parcel calculation to obtain tendencies. +! switch(2) = .T. - Includes entropy/q changes due to condensate loss and freezing. +! switch(3) = .T. - Adds the PBL Tpert for the parcel temperature at all levels. +! +! References: +! Raymond and Blythe (1992) JAS +! +! Author: +! Richard Neale - September 2004 +! +!----------------------------------------------------------------------- + implicit none +!----------------------------------------------------------------------- +! +! input arguments +! + integer, intent(in) :: nz ! vertical grid + integer, intent(in) :: nup ! number of plumes + +!+tht + !real(r8), intent(in), dimension(nz,nup) :: dmpdz ! Parcel fractional mass entrainment rate (/m) 3D + real(r8), intent(in) :: dmpdz(nz,nup) + !real(r8), intent(inout) :: dmpdz(nz,nup) +!-tht + + real(r8), intent(in) :: q(nz) ! spec. humidity + real(r8), intent(in) :: t(nz) ! temperature + real(r8), intent(in) :: p(nz) ! pressure + real(r8), intent(in) :: z(nz) ! height + real(r8), intent(in) :: pf(nz+1) ! pressure at interfaces + integer, intent(in) :: pblt ! index of pbl depth + real(r8), intent(in) :: tpert ! perturbation temperature by pbl processes + real(r8), intent(in) :: landfrac + +! +! output arguments +! + real(r8), intent(out) :: tp(nz,nup) ! parcel temperature + real(r8), intent(out) :: qstp(nz,nup) ! saturation mixing ratio of parcel (only above lcl, just q below). + real(r8), intent(out) :: tl(nup) ! parcel temperature at lcl + real(r8), intent(out) :: cape(nup) ! convective aval. pot. energy. + + real(r8), intent(out) :: cin (nup) !+tht: CIN + + integer, intent(out) :: lcl(nup) ! + integer, intent(out) :: lel(nup) ! + integer, intent(out) :: lon ! level of onset of deep convection + integer, intent(out) :: mx ! level of max moist static energy +! +!--------------------------Local Variables------------------------------ +! + integer lelten(nup,mf_num_cin) + real(r8) capeten(nup,mf_num_cin) ! provisional value of cape + real(r8) cinten(nup,mf_num_cin) !+tht provisional value of CIN + real(r8) tv(nz) + real(r8) tpv(nz,nup) + real(r8) buoy(nz,nup) + real(r8) pl(nup) + + real(r8) a1 + real(r8) a2 + real(r8) estp + real(r8) plexp + real(r8) hmax + real(r8) hmn + real(r8) y + + logical plge600(nup) + integer knt(nup) + + real(r8) e + + integer i + integer k + integer msg + integer n + + real(r8), parameter :: tiedke_add = 0.5_r8 +! +!----------------------------------------------------------------------- +! + do n = 1,mf_num_cin + do i = 1,nup + lelten(i,n) = 1 + capeten(i,n) = 0._r8 + cinten (i,n) = 0._r8 + end do + end do +! + lon = 1 + mx = lon + hmax = 0._r8 + + do i = 1,nup + knt(i) = 0 + lel(i) = 1 + cape(i) = 0._r8 + tp(:nz,i) = t(:nz) + qstp(:nz,i) = q(:nz) + end do + +!!! RBN - Initialize tv and buoy for output. +!!! tv=tv : tpv=tpv : qstp=q : buoy=0. + if (tht_tweaks) then +!+tht use system constants + tv (:nz) = t(:nz) *(1._r8+q(:nz)/epsilo)/ (1._r8+q(:nz)) !+tht + else + tv (:nz) = t(:nz) *(1._r8+1.608_r8*q(:nz))/ (1._r8+q(:nz)) + endif +!-tht + do i = 1,nup + tpv (:nz,i) = tv(:nz) + end do + buoy(:nz,:) = 0._r8 + +! +! set "launching" level(mx) to be at maximum moist static energy. +! search for this level stops at planetary boundary layer top. +! + do k = 1,msg-1 +!+tht: use total mse -- moist thermo + !hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k) + hmn =(cpair+q(k)*cpliq)*t(k)/(1._r8+q(k)) + (1._r8+q(k)/epsilo)/(1._r8+q(k))*gravit*z(k) & + +(latvap-(cpliq-cpwv)*(t(k)-tmelt))*q(k) +!-tht + if (k <= pblt .and. k >= lon .and. hmn > hmax) then + hmax = hmn + mx = k + end if + end do + +! LCL dilute calculation - initialize to mx(i) +! Determine lcl in parcel_dilute and get pl,tl after parcel_dilute +! Original code actually sets LCL as level above wher condensate forms. +! Therefore in parcel_dilute lcl(i) will be at first level where qsmix < qtmix. + + do i = 1,nup ! Initialise LCL variables. + lcl(i) = mx + tl(i) = t(mx) + pl(i) = p(mx) + end do + +! +! main buoyancy calculation. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! DILUTE PLUME CALCULATION USING ENTRAINING PLUME !!! +!!! RBN 9/9/04 !!! + +!+tht: add geop.height in argument to allow enthalpy mixing + call parcel_dilute(nz, nup, msg, mx, p, z, t, q, & + tpert, tp, tpv, qstp, pl, tl, lcl, & + landfrac, dmpdz) +!-tht + + +! If lcl is above the nominal level of non-divergence (600 mbs), +! no deep convection is permitted (ensuing calculations +! skipped and cape retains initialized value of zero). +! + do i = 1,nup + plge600(i) = pl(i).ge.600._r8 ! Just change to always allow buoy calculation. + end do + +! +! Main buoyancy calculation. +! + do k = 1,msg-1 + do i=1,nup + if (k >= mx .and. plge600(i)) then ! Define buoy from launch level to cloud top. + if (tht_tweaks) then + tv(k) = t(k)* (1._r8+q(k)/epsilo)/ (1._r8+q(k)) !+tht + else + tv(k) = t(k)* (1._r8+1.608_r8*q(k))/ (1._r8+q(k)) !orig + endif +! +0.5K or not? (arbitrary at this point - introduce in parcel_dilute instead? tht) + buoy(k,i) = tpv(k,i) - tv(k) + tiedke_add ! +0.5K or not? + else + qstp(k,i) = q(k) + tp(k,i) = t(k) + tpv(k,i) = tv(k) + endif + end do + end do + +!------------------------------------------------------------------------------- +! beginning from one below top (first level p>40hPa, msg) check for at most +! num_cin levels of neutral buoyancy (LELten) and compute CAPEten between LCL +! and those (tht) + do k = msg-2,1,-1 + do i = 1,nup + if (k > lcl(i) .and. plge600(i)) then + if (buoy(k-1,i) > 0._r8 .and. buoy(k,i) <= 0._r8) then + knt(i) = min(mf_num_cin,knt(i) + 1) + lelten(i,knt(i)) = k + end if + end if + end do + end do + +! calculate convective available potential energy (cape). + do n = 1,mf_num_cin + do k = msg-1,1,-1 + do i = 1,nup + if (plge600(i) .and. k >= mx .and. k < lelten(i,n)) then + !capeten(i,n) = capeten(i,n) + rair*buoy(k,i)*log(pf(k-1)/pf(k)) + capeten(i,n) = capeten(i,n) + rair*buoy(k,i)*log(pf(k)/pf(k+1)) +!+tht also compute total CIN + !cinten (i,n) = cinten (i,n) - rair*min(buoy(k,i),0._r8)*log(pf(k-1)/pf(k)) + cinten (i,n) = cinten (i,n) - rair*min(buoy(k,i),0._r8)*log(pf(k)/pf(k+1)) +!-tht + end if + end do + end do + end do + +! +! find maximum cape from all possible tentative capes from +! one sounding, +! and use it as the final cape, april 26, 1995 +! + do n = 1,mf_num_cin + do i = 1,nup + if (capeten(i,n) > cape(i)) then + cape(i) = capeten(i,n) + cin (i) = cinten (i,n) !+tht CIN + lel(i) = lelten(i,n) + end if + end do + end do +! +! put lower bound on cape for diagnostic purposes. +! + do i = 1,nup + cape(i) = max(cape(i), 0._r8) + end do +! + return +end subroutine buoyan_dilute + +!+tht + subroutine parcel_dilute (nz, nup, msg, klaunch, p, z, t, q, & + tpert, tp, tpv, qstp, pl, tl, lcl, & + landfrac, dmpdz) +!-tht + +! Routine to determine +! 1. Tp - Parcel temperature +! 2. qstp - Saturated mixing ratio at the parcel temperature. + +!-------------------- +implicit none +!-------------------- + +integer, intent(in) :: nz +integer, intent(in) :: nup +integer, intent(in) :: msg +integer, intent(in) :: klaunch + +real(r8), intent(in) :: tpert ! PBL temperature perturbation. +real(r8), intent(in) :: landfrac +real(r8), intent(in), dimension(nz) :: p +!+tht +real(r8), intent(in), dimension(nz) :: z +!-tht +real(r8), intent(in), dimension(nz) :: t +real(r8), intent(in), dimension(nz) :: q + +real(r8), intent(inout), dimension(nz,nup) :: tp ! Parcel temp. +real(r8), intent(inout), dimension(nz,nup) :: qstp ! Parcel water vapour (sat value above lcl). +real(r8), intent(inout), dimension(nup) :: tl ! Actual temp of LCL. +real(r8), intent(inout), dimension(nup) :: pl ! Actual pressure of LCL. +integer, intent(inout), dimension(nup) :: lcl ! Lifting condesation level (first model level with saturation). + +real(r8), intent(out), dimension(nz,nup) :: tpv ! Define tpv within this routine. + +!+tht +!real(r8), dimension(pcols) :: dmpdz ! Parcel fractional mass entrainment rate (/m) 2D + real(r8), dimension(nz,nup) :: dmpdz ! Parcel fractional mass entrainment rate (/m) 3D +!-tht + +!-------------------- + +! Have to be careful as s is also dry static energy. +!+tht +! in the mods below, s is used both as enthalpy (moist s.e.) and entropy +!-tht + +! If we are to retain the fact that CAM loops over grid-points in the internal +! loop then we need to dimension sp,atp,mp,xsh2o with ncol. + + +real(r8) tmix(nz,nup) ! Tempertaure of the entraining parcel. +real(r8) qtmix(nz,nup) ! Total water of the entraining parcel. +real(r8) qsmix(nz,nup) ! Saturated mixing ratio at the tmix. +real(r8) smix(nz,nup) ! Entropy of the entraining parcel. +real(r8) xsh2o(nz,nup) ! Precipitate lost from parcel. +real(r8) ds_xsh2o(nz,nup) ! Entropy change due to loss of condensate. +real(r8) ds_freeze(nz,nup) ! Entropy change sue to freezing of precip. +real(r8) dmpdz2d(nz,nup) ! variable detrainment rate + +!+tht +real(r8) zl(nup) ! lcl +!-tht + +real(r8) mp(nup) ! Parcel mass flux. +real(r8) qtp(nup) ! Parcel total water. +real(r8) sp(nup) ! Parcel entropy. + +real(r8) sp0(nup) ! Parcel launch entropy. +real(r8) qtp0(nup) ! Parcel launch total water. +real(r8) mp0(nup) ! Parcel launch relative mass flux. + +real(r8) lwmax ! Maximum condesate that can be held in cloud before rainout. +real(r8) dmpdp ! Parcel fractional mass entrainment rate (/mb). +!real(r8) dmpdpc ! In cloud parcel mass entrainment rate (/mb). +!real(r8) dmpdz ! Parcel fractional mass entrainment rate (/m) +real(r8) dpdz,dzdp ! Hydrstatic relation and inverse of. +real(r8) senv ! Environmental entropy at each grid point. +real(r8) qtenv ! Environmental total water " " ". +real(r8) penv ! Environmental total pressure " " ". +!+tht +real(r8) zenv +!-tht +real(r8) tenv ! Environmental total temperature " " ". +real(r8) new_s ! Hold value for entropy after condensation/freezing adjustments. +real(r8) new_q ! Hold value for total water after condensation/freezing adjustments. +real(r8) dp ! Layer thickness (center to center) +real(r8) tfguess ! First guess for entropy inversion - crucial for efficiency! +real(r8) tscool ! Super cooled temperature offset (in degC) (eg -35). + +real(r8) qxsk, qxskp1 ! LCL excess water (k, k+1) +real(r8) dsdp, dqtdp, dqxsdp ! LCL s, qt, p gradients (k, k+1) +real(r8) slcl,qtlcl,qslcl ! LCL s, qt, qs values. +real(r8) dmpdz_lnd, dmpdz_mask + +integer rcall ! Number of ientropy call for errors recording +integer nit_lheat ! Number of iterations for condensation/freezing loop. +integer i,k,ii ! Loop counters. + +real(r8) est +!====================================================================== +! SUMMARY +! +! 9/9/04 - Assumes parcel is initiated from level of maxh (klaunch) +! and entrains at each level with a specified entrainment rate. +! +! 15/9/04 - Calculates lcl(i) based on k where qsmix is first < qtmix. +! +!====================================================================== +! +! Set some values that may be changed frequently. +! + +nit_lheat = 2 ! iterations for ds,dq changes from condensation freezing. + +!+tht should not be necessary but for bit-reproducibility it turns out it is + !if (.not.tht_tweaks) then + ! dmpdz =-1.e-3_r8 ! Entrainment rate. (-ve for /m) + ! dmpdz_lnd=-1.e-3_r8 ! idem, on land + !endif +!-tht + +!dmpdpc = 3.e-2_r8 ! In cloud entrainment rate (/mb). + + lwmax = 1.e-3_r8 ! Need to put formula in for this. + tscool = 0.0_r8 ! Temp at which water loading freezes in the cloud. +!+tht +!lwmax = 1.e10_r8 ! tht: don't precipitate +!tscool =-10._r8 ! tht: allow even just mild supercooling?! +!-tht + +qtmix=0._r8 +smix=0._r8 + +qtenv = 0._r8 +senv = 0._r8 +tenv = 0._r8 +penv = 0._r8 +!+tht +zenv = 0._r8 +!-tht + +qtp0 = 0._r8 +sp0 = 0._r8 +mp0 = 0._r8 + +qtp = 0._r8 +sp = 0._r8 +mp = 0._r8 + +new_q = 0._r8 +new_s = 0._r8 + +zl(:)=0._r8 + +! **** Begin loops **** + +do k = 1,msg-1 + do i=1,nup + +! Initialize parcel values at launch level. + + if (k == klaunch) then + qtp0(i) = q(k) ! Parcel launch total water (assuming subsaturated) - OK????. + +!+tht: formulate dilution on enthalpy not on entropy + if (tht_tweaks) then + sp0(i) = enthalpy(t(k),p(k),qtp0(i),z(k)) ! Parcel launch enthalpy. + else + sp0(i) = entropy (t(k),p(k),qtp0(i)) ! Parcel launch entropy. + endif +!-tht + mp0(i) = 1._r8 ! Parcel launch relative mass (=1 for dmpdp=0 i.e. undilute). + smix(k,i) = sp0(i) + qtmix(k,i) = qtp0(i) +!+tht: since the function to invert for T is *identical* with sp0(i)=entropy(t), unless there is +! a coding error (likely, given the mess) the result must be t(i,k) (verified 21/2/2014) + if (tht_tweaks) then + tmix(k,i) = t(k) + call qsat_hPa(tmix(k,i),p(k), est, qsmix(k,i)) + else + tfguess = t(k) + rcall = 1 + call ientropy (rcall,smix(k,i),p(k),qtmix(k,i),tmix(k,i),qsmix(k,i),tfguess) + endif +!-tht + end if + +! Entraining levels + + if (k > klaunch) then + +! Set environmental values for this level. + + dp = (p(k)-p(k-1)) ! In -ve mb as p decreasing with height - difference between center of layers. + qtenv = 0.5_r8*(q(k)+q(k-1)) ! Total water of environment. + tenv = 0.5_r8*(t(k)+t(k-1)) + penv = 0.5_r8*(p(k)+p(k-1)) +!+tht + zenv = 0.5_r8*(z(k)+z(k-1)) +!-tht + +!+tht: base plume dilution on enthalpy not on entropy + if (tht_tweaks) then + senv = enthalpy(tenv,penv,qtenv,zenv) ! Enthalpy of environment. + else + senv = entropy (tenv,penv,qtenv) ! Entropy of environment. + endif +!-tht + +! Determine fractional entrainment rate /pa given value /m. + + dpdz = -(penv*gravit)/(rair*tenv) ! in mb/m since p in mb. + dzdp = 1._r8/dpdz ! in m/mb +!+tht +! NB: land fudge makes no sense to me - make dmpdz_lnd=dmpdz (as per default code, hard-wired to 1e-3) + !dmpdp = dmpdz*dzdp + !dmpdp = dmpdz(i)*dzdp ! /mb Fractional entrainment 2D + dmpdp = dmpdz(k,i)*dzdp ! /mb Fractional entrainment 3D +!-tht + +! Sum entrainment to current level +! entrains q,s out of intervening dp layers, in which linear variation is assumed +! so really it entrains the mean of the 2 stored values. + + sp(i) = sp(i) - dmpdp*dp*senv + qtp(i) = qtp(i) - dmpdp*dp*qtenv + mp(i) = mp(i) - dmpdp*dp + +! Entrain s and qt to next level. + + smix(k,i) = (sp0(i) + sp(i)) / (mp0(i) + mp(i)) + qtmix(k,i) = (qtp0(i) + qtp(i)) / (mp0(i) + mp(i)) + +! Invert entropy from s and q to determine T and saturation-capped q of mixture. +! t(i,k) used as a first guess so that it converges faster. + + tfguess = tmix(k-1,i) + rcall = 2 +!+tht + if (tht_tweaks) then + call ienthalpy(rcall,smix(k,i),p(k),z(k),qtmix(k,i),tmix(k,i),qsmix(k,i),tfguess) + else + call ientropy (rcall,smix(k,i),p(k),qtmix(k,i),tmix(k,i),qsmix(k,i),tfguess) + endif +!-tht + +! +! Determine if this is lcl of this column if qsmix <= qtmix. +! FIRST LEVEL where this happens on ascending. + if (qsmix(k,i) <= qtmix(k,i) .and. qsmix(k-1,i) > qtmix(k-1,i)) then + lcl(i) = k + qxsk = qtmix(k,i) - qsmix(k,i) + qxskp1 = qtmix(k-1,i) - qsmix(k-1,i) + dqxsdp = (qxsk - qxskp1)/dp + pl(i) = p(k-1) - qxskp1/dqxsdp ! pressure level of actual lcl. +!+tht + zl(i) = z(k-1) - qxskp1/dqxsdp *dzdp +!-tht + dsdp = (smix(k,i) - smix(k-1,i))/dp + dqtdp = (qtmix(k,i) - qtmix(k-1,i))/dp + slcl = smix(k-1,i) + dsdp* (pl(i)-p(k-1)) + qtlcl = qtmix(k-1,i) + dqtdp*(pl(i)-p(k-1)) + + tfguess = tmix(k,i) + rcall = 3 +!+tht + if (tht_tweaks) then + call ienthalpy(rcall,slcl,pl(i),zl(i),qtlcl,tl(i),qslcl,tfguess) + else + call ientropy (rcall,slcl,pl(i),qtlcl,tl(i),qslcl,tfguess) + endif +!-tht + +! write(iulog,*)' ' +! write(iulog,*)' p',p(i,k+1),pl(i),p(i,lcl(i)) +! write(iulog,*)' t',tmix(i,k+1),tl(i),tmix(i,lcl(i)) +! write(iulog,*)' s',smix(i,k+1),slcl,smix(i,lcl(i)) +! write(iulog,*)'qt',qtmix(i,k+1),qtlcl,qtmix(i,lcl(i)) +! write(iulog,*)'qs',qsmix(i,k+1),qslcl,qsmix(i,lcl(i)) + + endif +! + end if ! k < klaunch + + + end do ! Levels loop +end do ! Columns loop + + +! if ( masterproc ) then +! do k = 1,msg-1 +! do i = 1,nup +! write(iulog,*) "after, k, nup, dmpdz ", k, i, dmpdz(k,i) +! end do +! end do +! end if + + +!!!!!!!!!!!!!!!!!!!!!!!!!!END ENTRAINMENT LOOP!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!! Could stop now and test with this as it will provide some estimate of buoyancy +!! without the effects of freezing/condensation taken into account for tmix. + +!! So we now have a profile of entropy and total water of the entraining parcel +!! Varying with height from the launch level klaunch parcel=environment. To the +!! top allowed level for the existence of convection. + +!! Now we have to adjust these values such that the water held in vaopor is < or +!! = to qsmix. Therefore, we assume that the cloud holds a certain amount of +!! condensate (lwmax) and the rest is rained out (xsh2o). This, obviously +!! provides latent heating to the mixed parcel and so this has to be added back +!! to it. But does this also increase qsmix as well? Also freezing processes + + +xsh2o = 0._r8 +ds_xsh2o = 0._r8 +ds_freeze = 0._r8 + +!!!!!!!!!!!!!!!!!!!!!!!!!PRECIPITATION/FREEZING LOOP!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Iterate solution twice for accuracy + + + +do k = 1, msg-1 + do i=1,nup + +! Initialize variables at k=klaunch + + if (k == klaunch) then + +! Set parcel values at launch level assume no liquid water. + + tp(k,i) = tmix(k,i) + qstp(k,i) = q(k) + if (tht_tweaks) then + tpv(k,i) = (tp(k,i) + tpert) * (1._r8+qstp(k,i)/epsilo) / (1._r8+qstp(k,i)) !+tht OK with mx ratio + else + tpv(k,i) = (tp(k,i) + tpert) * (1._r8+1.608_r8*qstp(k,i)) / (1._r8+qstp(k,i)) + endif + + end if + + if (k > klaunch) then + + if (tht_tweaks) then + smix(k,i)=entropy(tmix(k,i),p(k),qtmix(k,i)) !+tht make sure to use entropy here + endif + +!---- +! Initiate loop if switch(2) = .T. - RBN:DILUTE - TAKEN OUT BUT COULD BE RETURNED LATER. +! Iterate nit_lheat times for s,qt changes. + do ii=0,nit_lheat-1 + +! Rain (xsh2o) is excess condensate, bar LWMAX (Accumulated loss from qtmix). + xsh2o(k,i) = max (0._r8, qtmix(k,i) - qsmix(k,i) - lwmax) + +! Contribution to ds from precip loss of condensate (Accumulated change from smix).(-ve) + ds_xsh2o(k,i) = ds_xsh2o(k-1,i) - cpliq * log (tmix(k,i)/tmelt) * max(0._r8,(xsh2o(k,i)-xsh2o(k-1,i))) +! +! Entropy of freezing: latice times amount of water involved divided by T. +! + if (tmix(k,i) <= tmelt+tscool .and. ds_freeze(k-1,i) == 0._r8) then ! One off freezing of condensate. + ds_freeze(k,i) = (latice/tmix(k,i)) * max(0._r8,qtmix(k,i)-qsmix(k,i)-xsh2o(k,i)) ! Gain of LH + end if + + if (tmix(k,i) <= tmelt+tscool .and. ds_freeze(k-1,i) /= 0._r8) then ! Continual freezing of additional condensate. + ds_freeze(k,i) = ds_freeze(k-1,i)+(latice/tmix(k,i)) * max(0._r8,(qsmix(k-1,i)-qsmix(k,i))) + end if + +! Adjust entropy and accordingly to sum of ds (be careful of signs). + new_s = smix(k,i) + ds_xsh2o(k,i) + ds_freeze(k,i) + +! Adjust liquid water and accordingly to xsh2o. + new_q = qtmix(k,i) - xsh2o(k,i) + +! Invert entropy to get updated Tmix and qsmix of parcel. + + tfguess = tmix(k,i) + rcall =4 + call ientropy (rcall,new_s, p(k), new_q, tmix(k,i), qsmix(k,i), tfguess) + + end do ! Iteration loop for freezing processes. + +! tp - Parcel temp is temp of mixture. +! tpv - Parcel v. temp should be density temp with new_q total water. + + tp(k,i) = tmix(k,i) + +! tpv = tprho in the presence of condensate (i.e. when new_q > qsmix) + if (new_q > qsmix(k,i)) then ! Super-saturated so condensate present - reduces buoyancy. + qstp(k,i) = qsmix(k,i) + else ! Just saturated/sub-saturated - no condensate virtual effects. + qstp(k,i) = new_q + end if + + if (tht_tweaks) then + tpv(k,i) = (tp(k,i)+tpert)* (1._r8+qstp(k,i)/epsilo) / (1._r8+ new_q) !+tht + else + tpv(k,i) = (tp(k,i)+tpert)* (1._r8+1.608_r8*qstp(k,i)) / (1._r8+ new_q) + endif + + end if ! k > klaunch + + end do ! Loop for columns + +end do ! Loop for vertical levels. + + +return +end subroutine parcel_dilute + +!----------------------------------------------------------------------------------------- +real(r8) function entropy(TK,p,qtot) +!----------------------------------------------------------------------------------------- +! +! TK(K),p(mb),qtot(kg/kg) +! from Raymond and Blyth 1992 +! + real(r8), intent(in) :: p,qtot,TK + real(r8) :: qv,qst,e,est,L + real(r8), parameter :: pref = 1000._r8 + +L = latvap - (cpliq - cpwv)*(TK-tmelt) ! T IN CENTIGRADE + +call qsat_hPa(TK, p, est, qst) + +qv = min(qtot,qst) ! Partition qtot into vapor part only. +e = qv*p / (epsilo +qv) + +entropy = (cpair + qtot*cpliq)*log( TK/tmelt) - rair*log( (p-e)/pref ) + & + L*qv/TK - qv*rh2o*log(qv/qst) + +end FUNCTION entropy + +! +!----------------------------------------------------------------------------------------- +SUBROUTINE ientropy (rcall,s,p,qt,T,qst,Tfg) +!----------------------------------------------------------------------------------------- +! +! p(mb), Tfg/T(K), qt/qv(kg/kg), s(J/kg). +! Inverts entropy, pressure and total water qt +! for T and saturated vapor mixing ratio +! + + integer, intent(in) :: rcall + real(r8), intent(in) :: s, p, Tfg, qt + real(r8), intent(out) :: qst, T + real(r8) :: est + real(r8) :: a,b,c,d,ebr,fa,fb,fc,pbr,qbr,rbr,sbr,tol1,xm,tol + integer :: i + + logical :: converged + + ! Max number of iteration loops. + integer, parameter :: LOOPMAX = 100 + real(r8), parameter :: EPS = 3.e-8_r8 + + converged = .false. + + ! Invert the entropy equation -- use Brent's method + ! Brent, R. P. Ch. 3-4 in Algorithms for Minimization Without Derivatives. Englewood Cliffs, NJ: Prentice-Hall, 1973. + + T = Tfg ! Better first guess based on Tprofile from conv. + + a = Tfg-10 !low bracket + b = Tfg+10 !high bracket + + fa = entropy(a, p, qt) - s + fb = entropy(b, p, qt) - s + + c=b + fc=fb + tol=0.001_r8 + + converge: do i=0, LOOPMAX + if ((fb > 0.0_r8 .and. fc > 0.0_r8) .or. & + (fb < 0.0_r8 .and. fc < 0.0_r8)) then + c=a + fc=fa + d=b-a + ebr=d + end if + if (abs(fc) < abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + end if + + tol1=2.0_r8*EPS*abs(b)+0.5_r8*tol + xm=0.5_r8*(c-b) + converged = (abs(xm) <= tol1 .or. fb == 0.0_r8) + if (converged) exit converge + + if (abs(ebr) >= tol1 .and. abs(fa) > abs(fb)) then + sbr=fb/fa + if (a == c) then + pbr=2.0_r8*xm*sbr + qbr=1.0_r8-sbr + else + qbr=fa/fc + rbr=fb/fc + pbr=sbr*(2.0_r8*xm*qbr*(qbr-rbr)-(b-a)*(rbr-1.0_r8)) + qbr=(qbr-1.0_r8)*(rbr-1.0_r8)*(sbr-1.0_r8) + end if + if (pbr > 0.0_r8) qbr=-qbr + pbr=abs(pbr) + if (2.0_r8*pbr < min(3.0_r8*xm*qbr-abs(tol1*qbr),abs(ebr*qbr))) then + ebr=d + d=pbr/qbr + else + d=xm + ebr=d + end if + else + d=xm + ebr=d + end if + a=b + fa=fb + b=b+merge(d,sign(tol1,xm), abs(d) > tol1 ) + + fb = entropy(b, p, qt) - s + + end do converge + + T = b + call qsat_hPa(T, p, est, qst) + + if (.not. converged) then + call endrun('**** ZM_CONV IENTROPY: Tmix did not converge ****') + end if + +100 format (A,I1,I4,I4,7(A,F6.2)) + +end SUBROUTINE ientropy + +! Wrapper for qsat_water that does translation between Pa and hPa +! qsat_water uses Pa internally, so get it right, need to pass in Pa. +! Afterward, set es back to hPa. +subroutine qsat_hPa(t, p, es, qm) + use wv_saturation, only: qsat_water + + ! Inputs + real(r8), intent(in) :: t ! Temperature (K) + real(r8), intent(in) :: p ! Pressure (hPa) + ! Outputs + real(r8), intent(out) :: es ! Saturation vapor pressure (hPa) + real(r8), intent(out) :: qm ! Saturation mass mixing ratio + ! (vapor mass over dry mass, kg/kg) + + call qsat_water(t, p*100._r8, es, qm) + + es = es*0.01_r8 + +end subroutine qsat_hPa + +!----------------------------------------------------------------------------------------- +real(r8) function enthalpy(TK,p,qtot,z) +!----------------------------------------------------------------------------------------- +! +! TK(K),p(mb),qtot(kg/kg) +! + real(r8), intent(in) :: p,qtot,TK,z + real(r8) :: qv,qst,e,est,L + +L = latvap - (cpliq - cpwv)*(TK-tmelt) + +call qsat_hPa(TK, p, est, qst) +qv = min(qtot,qst) ! Partition qtot into vapor part only. + +!enthalpy = (cpres + qtot*cpliq)*(TK-tfreez) + L*qv + (1._r8+qtot)*grav*z + enthalpy = (cpair + qtot*cpliq)* TK + L*qv + (1._r8+qtot)*gravit*z + +return +end FUNCTION enthalpy + +!----------------------------------------------------------------------------------------- + SUBROUTINE ienthalpy (rcall,s,p,z,qt,T,qst,Tfg) !identical with iENTROPY, only function calls swapped +!----------------------------------------------------------------------------------------- +! +! p(mb), Tfg/T(K), qt/qv(kg/kg), s(J/kg). +! Inverts entropy, pressure and total water qt +! for T and saturated vapor mixing ratio +! + + integer, intent(in) :: rcall + real(r8), intent(in) :: s, p, z, Tfg, qt + real(r8), intent(out) :: qst, T + real(r8) :: est + real(r8) :: a,b,c,d,ebr,fa,fb,fc,pbr,qbr,rbr,sbr,tol1,xm,tol + integer :: i + + logical :: converged + + ! Max number of iteration loops. + integer, parameter :: LOOPMAX = 100 + real(r8), parameter :: EPS = 3.e-8_r8 + + converged = .false. + + ! Invert the entropy equation -- use Brent's method + ! Brent, R. P. Ch. 3-4 in Algorithms for Minimization Without Derivatives. Englewood Cliffs, NJ: Prentice-Hall, 1973. + + T = Tfg ! Better first guess based on Tprofile from conv. + + a = Tfg-10 !low bracket + b = Tfg+10 !high bracket + + fa = enthalpy(a, p, qt,z) - s + fb = enthalpy(b, p, qt,z) - s + + c=b + fc=fb + tol=0.001_r8 + + converge: do i=0, LOOPMAX + if ((fb > 0.0_r8 .and. fc > 0.0_r8) .or. & + (fb < 0.0_r8 .and. fc < 0.0_r8)) then + c=a + fc=fa + d=b-a + ebr=d + end if + if (abs(fc) < abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + end if + + tol1=2.0_r8*EPS*abs(b)+0.5_r8*tol + xm=0.5_r8*(c-b) + converged = (abs(xm) <= tol1 .or. fb == 0.0_r8) + if (converged) exit converge + + if (abs(ebr) >= tol1 .and. abs(fa) > abs(fb)) then + sbr=fb/fa + if (a == c) then + pbr=2.0_r8*xm*sbr + qbr=1.0_r8-sbr + else + qbr=fa/fc + rbr=fb/fc + pbr=sbr*(2.0_r8*xm*qbr*(qbr-rbr)-(b-a)*(rbr-1.0_r8)) + qbr=(qbr-1.0_r8)*(rbr-1.0_r8)*(sbr-1.0_r8) + end if + if (pbr > 0.0_r8) qbr=-qbr + pbr=abs(pbr) + if (2.0_r8*pbr < min(3.0_r8*xm*qbr-abs(tol1*qbr),abs(ebr*qbr))) then + ebr=d + d=pbr/qbr + else + d=xm + ebr=d + end if + else + d=xm + ebr=d + end if + a=b + fa=fb + b=b+merge(d,sign(tol1,xm), abs(d) > tol1 ) + + fb = enthalpy(b, p, qt,z) - s + + end do converge + + T = b + call qsat_hPa(T, p, est, qst) + + if (.not. converged) then + call endrun('**** ZM_CONV IENTHALPY: Tmix did not converge ****') + end if + +100 format (A,I1,I4,I4,7(A,F6.2)) + + end SUBROUTINE ienthalpy + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +end module clubb_mf diff --git a/src/physics/cam/convect_shallow.F90 b/src/physics/cam/convect_shallow.F90 index a6802e45e9..79ed7e03b4 100644 --- a/src/physics/cam/convect_shallow.F90 +++ b/src/physics/cam/convect_shallow.F90 @@ -724,7 +724,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair - call outfld( 'ICWMRSH ', icwmr , pcols , lchnk ) +! call outfld( 'ICWMRSH ', icwmr , pcols , lchnk ) ! For CLUBB-MF, need to output ICWMRSH in clubb_intr call outfld( 'CMFDT ', ftem , pcols , lchnk ) call outfld( 'CMFDQ ', ptend_loc%q(1,1,1) , pcols , lchnk ) diff --git a/src/physics/cam/iop_forcing.F90 b/src/physics/cam/iop_forcing.F90 index 55259685b5..f5db9cd5d1 100644 --- a/src/physics/cam/iop_forcing.F90 +++ b/src/physics/cam/iop_forcing.F90 @@ -29,6 +29,8 @@ subroutine scam_use_iop_srf( cam_in ) use physconst, only: stebol, latvap use scamMod use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use spmd_utils, only: masterproc implicit none save diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index 4add6a170c..a3647e886a 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -2288,6 +2288,10 @@ subroutine tphysbc (ztodt, state, & real(r8) :: prec_sed_macmic(pcols) real(r8) :: snow_sed_macmic(pcols) + ! CLUBB+MF + real(r8) :: prec_sh_macmic(pcols) + real(r8) :: snow_sh_macmic(pcols) + ! energy checking variables real(r8) :: zero(pcols) ! array of zeros real(r8) :: zero_sc(pcols*psubcols) ! array of zeros @@ -2655,6 +2659,10 @@ subroutine tphysbc (ztodt, state, & prec_pcw_macmic = 0._r8 snow_pcw_macmic = 0._r8 + ! CLUBB+MF + prec_sh_macmic = 0._r8 + snow_sh_macmic = 0._r8 + ! contrail parameterization ! see Chen et al., 2012: Global contrail coverage simulated ! by CAM5 with the inventory of 2006 global aircraft emissions, JAMES @@ -2735,7 +2743,9 @@ subroutine tphysbc (ztodt, state, & ! Since we "added" the reserved liquid back in this routine, we need ! to account for it in the energy checker - flx_cnd(:ncol) = -1._r8*rliq(:ncol) + + ! CLUBB+MF: add MF precip to flx_cnd [m/s] + flx_cnd(:ncol) = -1._r8*rliq(:ncol) + prec_sh(:ncol) flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) ! Unfortunately, physics_update does not know what time period @@ -2770,6 +2780,10 @@ subroutine tphysbc (ztodt, state, & call t_stopf('macrop_tend') + ! CLUBB+MF + prec_sh_macmic(:ncol) = prec_sh_macmic(:ncol) + prec_sh(:ncol) + snow_sh_macmic(:ncol) = snow_sh_macmic(:ncol) + snow_sh(:ncol) + !=================================================== ! Calculate cloud microphysics !=================================================== @@ -2923,6 +2937,10 @@ subroutine tphysbc (ztodt, state, & prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) + ! CLUBB+MF + prec_sh(:ncol) = prec_sh_macmic(:ncol)/cld_macmic_num_steps + snow_sh(:ncol) = snow_sh_macmic(:ncol)/cld_macmic_num_steps + endif ! Add the precipitation from CARMA to the precipitation from stratiform. diff --git a/src/physics/cam/ref_pres.F90 b/src/physics/cam/ref_pres.F90 index 19781a6ab7..6ee2157149 100644 --- a/src/physics/cam/ref_pres.F90 +++ b/src/physics/cam/ref_pres.F90 @@ -145,6 +145,7 @@ subroutine ref_pres_init(pref_edge_in, pref_mid_in, num_pr_lev_in) ! Find level corresponding to the molecular diffusion bottom. do_molec_diff = (ptop_ref < do_molec_press) + if (do_molec_diff) then nbot_molec = press_lim_idx(molec_diff_bot_press, & top=.false.) diff --git a/src/physics/cam7/convect_diagnostics.F90 b/src/physics/cam7/convect_diagnostics.F90 index 1ea7b38221..3f2054f45d 100644 --- a/src/physics/cam7/convect_diagnostics.F90 +++ b/src/physics/cam7/convect_diagnostics.F90 @@ -81,6 +81,8 @@ subroutine convect_diagnostics_init use physics_buffer, only: pbuf_get_index call addfld( 'CMFMC', (/ 'ilev' /), 'A', 'kg/m2/s', 'Moist convection (deep+shallow) mass flux' ) + call addfld ('ICWMRSH', (/ 'lev' /), 'A', 'kg/kg', 'Shallow Convection in-cloud water mixing ratio ' ) + call addfld( 'PRECSH', horiz_only, 'A', 'm/s', 'Shallow Convection precipitation rate' ) call addfld( 'CLDTOP', horiz_only, 'I', '1', 'Vertical index of cloud top' ) call addfld( 'CLDBOT', horiz_only, 'I', '1', 'Vertical index of cloud base' ) call addfld( 'PCLDTOP', horiz_only, 'A', 'Pa', 'Pressure of cloud top' ) @@ -200,7 +202,7 @@ subroutine convect_diagnostics_calc( ztodt , cmfmc , & if( cnb2(i) > cnb(i)) cnb(i) = cnb2(i) if( cnb(i) == 1._r8 ) cnb(i) = cnt(i) pcnt(i) = state%pmid(i,int(cnt(i))) - pcnb(i) = state%pmid(i,int(cnb(i))) + pcnb(i) = state%pmid(i,int(cnb(i))) end do ! ----------------------------------------------- ! diff --git a/src/physics/cam7/physpkg.F90 b/src/physics/cam7/physpkg.F90 index 0f7041e8f9..f9b8cc5abc 100644 --- a/src/physics/cam7/physpkg.F90 +++ b/src/physics/cam7/physpkg.F90 @@ -1509,6 +1509,10 @@ subroutine tphysac (ztodt, cam_in, & real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation + ! CLUBB+MF + real(r8),pointer :: prec_sh(:) ! total precipitation from Hack convection + real(r8),pointer :: snow_sh(:) ! snow from Hack convection + ! Local copies for substepping real(r8) :: prec_pcw_macmic(pcols) real(r8) :: snow_pcw_macmic(pcols) @@ -1519,6 +1523,10 @@ subroutine tphysac (ztodt, cam_in, & real(r8) :: prec_sed_carma(pcols) ! total precip from cloud sedimentation (CARMA) real(r8) :: snow_sed_carma(pcols) ! snow from cloud ice sedimentation (CARMA) + ! CLUBB+MF + real(r8) :: prec_sh_macmic(pcols) + real(r8) :: snow_sh_macmic(pcols) + logical :: labort ! abort flag real(r8) tvm(pcols,pver) ! virtual temperature @@ -1606,6 +1614,9 @@ subroutine tphysac (ztodt, cam_in, & call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) end if + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh ) + call pbuf_get_field(pbuf, snow_sh_idx, snow_sh ) + if (dlfzm_idx > 0) then call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) dlf(:ncol,:) = dlfzm(:ncol,:) @@ -1722,6 +1733,10 @@ subroutine tphysac (ztodt, cam_in, & prec_pcw_macmic = 0._r8 snow_pcw_macmic = 0._r8 + ! CLUBB+MF + prec_sh_macmic = 0._r8 + snow_sh_macmic = 0._r8 + ! contrail parameterization ! see Chen et al., 2012: Global contrail coverage simulated ! by CAM5 with the inventory of 2006 global aircraft emissions, JAMES @@ -1756,7 +1771,7 @@ subroutine tphysac (ztodt, cam_in, & ! Since we "added" the reserved liquid back in this routine, we need ! to account for it in the energy checker - flx_cnd(:ncol) = -1._r8*rliq(:ncol) + flx_cnd(:ncol) = -1._r8*rliq(:ncol) + prec_sh(:ncol) flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) ! Unfortunately, physics_update does not know what time period @@ -1789,6 +1804,10 @@ subroutine tphysac (ztodt, cam_in, & call t_stopf('macrop_tend') + ! CLUBB+MF + prec_sh_macmic(:ncol) = prec_sh_macmic(:ncol) + prec_sh(:ncol) + snow_sh_macmic(:ncol) = snow_sh_macmic(:ncol) + snow_sh(:ncol) + !=================================================== ! Calculate cloud microphysics !=================================================== @@ -1936,6 +1955,10 @@ subroutine tphysac (ztodt, cam_in, & prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) + ! CLUBB+MF + prec_sh(:ncol) = prec_sh_macmic(:ncol)/cld_macmic_num_steps + snow_sh(:ncol) = snow_sh_macmic(:ncol)/cld_macmic_num_steps + endif ! Add the precipitation from CARMA to the precipitation from stratiform. diff --git a/src/physics/clubb b/src/physics/clubb index 15e802092f..d224307f79 160000 --- a/src/physics/clubb +++ b/src/physics/clubb @@ -1 +1 @@ -Subproject commit 15e802092f65b3a20e5d67cb32d40f8a2771ca9b +Subproject commit d224307f798b654f5312a9f035568c8a99ca400c diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90 index efc271b70d..66237eb587 100644 --- a/src/physics/rrtmg/radiation.F90 +++ b/src/physics/rrtmg/radiation.F90 @@ -392,6 +392,7 @@ subroutine radiation_init(pbuf2d) call rad_data_init(pbuf2d) ! initialize output fields for offline driver call radsw_init() call radlw_init() + call cloud_rad_props_init(tiny) cld_idx = pbuf_get_index('CLD') diff --git a/src/utils/time_manager.F90 b/src/utils/time_manager.F90 index aeeae9b3f4..bf40b296c8 100644 --- a/src/utils/time_manager.F90 +++ b/src/utils/time_manager.F90 @@ -26,8 +26,10 @@ module time_manager get_curr_date, &! return date components at end of current timestep get_prev_date, &! return date components at beginning of current timestep get_start_date, &! return components of the start date +!+++arh get_stop_date, &! return components of the stop date get_run_duration, &! return run duration in whole days and remaining seconds + get_ref_date, &! return components of the reference date get_perp_date, &! return components of the perpetual date, and current time of day get_curr_time, &! return components of elapsed time since reference date at end of current timestep @@ -690,6 +692,18 @@ subroutine get_start_date(yr, mon, day, tod) call chkrc(rc, sub//': error return from ESMF_TimeGet') end subroutine get_start_date +!========================================================================================= + +! NOTE: The following wrappers (e.g., get_stop_date) are maintained to satisfy +! external MPAS build/link requirements. Some MPAS configurations expect +! these specific time_manager entry points to be available; if they are +! missing, the MPAS build fails with unresolved symbol errors. +! +! These routines follow the same pattern as get_start_date/get_prev_date +! and simply expose ESMF_Clock/ESMF_Time state through the legacy CAM +! interface used by MPAS. Do not remove or rename them unless the MPAS +! coupling/interface code has been updated to stop referencing them and +! the build has been verified without these wrappers. !========================================================================================= @@ -748,6 +762,8 @@ end subroutine get_run_duration !========================================================================================= +!---arh + subroutine get_ref_date(yr, mon, day, tod) ! Return date components of the reference date. @@ -1214,6 +1230,7 @@ subroutine timemgr_time_inc(ymd1, tod1, ymd2, tod2, inc_s, inc_h, inc_d) type(ESMF_Time) :: date1 type(ESMF_Time) :: date2 + type(ESMF_TimeInterval) :: t_interval integer :: year, month, day !-----------------------------------------------------------------------------------------