diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index b66e4a2d25..03698dc3f6 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -50,7 +50,7 @@ tag = ALI_ARMS_v1.0.1 required = True [atmos_phys] -tag = atmos_phys0_01_000 +tag = atmos_phys0_02_000 protocol = git repo_url = https://github.com/ESCOMP/atmospheric_physics required = True diff --git a/bld/build-namelist b/bld/build-namelist index fcf1cfca79..97bcbcd991 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -3500,7 +3500,6 @@ if (!$simple_phys) { add_default($nl, 'zmconv_ke'); add_default($nl, 'zmconv_ke_lnd'); add_default($nl, 'zmconv_org'); - add_default($nl, 'zmconv_microp'); add_default($nl, 'zmconv_num_cin'); add_default($nl, 'zmconv_dmpdz'); add_default($nl, 'zmconv_tiedke_add'); diff --git a/bld/configure b/bld/configure index ac68bed627..fc9151315b 100755 --- a/bld/configure +++ b/bld/configure @@ -2250,6 +2250,9 @@ sub write_filepath # in the list of filepaths. print $fh "$camsrcdir/src/physics/cam\n"; + #Add the CCPP'ized subdirectories + print $fh "$camsrcdir/src/atmos_phys/zm\n"; + # Dynamics package and test utilities print $fh "$camsrcdir/src/dynamics/$dyn\n"; if($dyn eq 'se') { diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index ddcef1fdd3..16cf8e67db 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -2795,7 +2795,6 @@ .false. .true. - .false. 5 1 1 diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 21fa4adead..286bf4f953 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -3266,12 +3266,6 @@ if -zmconv_org is set in configure. Default: .false., unless -zmconv_org set in configure - -Turn on convective microphysics -Default: .false. - - The number of negative buoyancy regions that are allowed before the convection top and CAPE calculations are completed. diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 193e3d4246..384387edc2 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -329,16 +329,6 @@ - - - - - - - - - - @@ -519,16 +509,6 @@ - - - - - - - - - - diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/shell_commands deleted file mode 100644 index 3a506cfaa1..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/shell_commands +++ /dev/null @@ -1,4 +0,0 @@ -./xmlchange ROF_NCPL=\$ATM_NCPL -./xmlchange GLC_NCPL=\$ATM_NCPL -./xmlchange CAM_NML_USE_CASE=UNSET -./xmlchange RUN_STARTDATE="19950101" diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_cam deleted file mode 100644 index f81fb38bfc..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_cam +++ /dev/null @@ -1,6 +0,0 @@ -zmconv_microp=.true. -mfilt=1,1,1,1,1,1 -ndens=1,1,1,1,1,1 -nhtfrq=3,3,3,3,3,3 -inithist='ENDOFRUN' -pbuf_global_allocate=.false. diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_clm b/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_clm deleted file mode 100644 index f3ac27f1e6..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_clm +++ /dev/null @@ -1,27 +0,0 @@ -!---------------------------------------------------------------------------------- -! Users should add all user specific namelist changes below in the form of -! namelist_var = new_namelist_value -! -! Include namelist variables for drv_flds_in ONLY if -megan and/or -drydep options -! are set in the CLM_NAMELIST_OPTS env variable. -! -! EXCEPTIONS: -! Set use_cndv by the compset you use and the CLM_BLDNML_OPTS -dynamic_vegetation setting -! Set use_vichydro by the compset you use and the CLM_BLDNML_OPTS -vichydro setting -! Set use_cn by the compset you use and CLM_BLDNML_OPTS -bgc setting -! Set use_crop by the compset you use and CLM_BLDNML_OPTS -crop setting -! Set spinup_state by the CLM_BLDNML_OPTS -bgc_spinup setting -! Set irrigate by the CLM_BLDNML_OPTS -irrig setting -! Set dtime with L_NCPL option -! Set fatmlndfrc with LND_DOMAIN_PATH/LND_DOMAIN_FILE options -! Set finidat with RUN_REFCASE/RUN_REFDATE/RUN_REFTOD options for hybrid or branch cases -! (includes $inst_string for multi-ensemble cases) -! Set glc_grid with CISM_GRID option -! Set glc_smb with GLC_SMB option -! Set maxpatch_glcmec with GLC_NEC option -! Set glc_do_dynglacier with GLC_TWO_WAY_COUPLING env variable -!---------------------------------------------------------------------------------- -hist_nhtfrq = 3 -hist_mfilt = 1 -hist_ndens = 1 - diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_cpl b/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_cpl deleted file mode 100644 index 398535cf65..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_cpl +++ /dev/null @@ -1,2 +0,0 @@ -reprosum_diffmax=1.0e-14 -reprosum_recompute=.true. diff --git a/doc/ChangeLog b/doc/ChangeLog index 2cb653ca46..a219f92580 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,94 @@ =============================================================== +Tag name: cam6_3_146 +Originator(s): cacraig +Date: Jan 23, 2024 +One-line Summary: ZM clean up in preparation for using via CCPP and remove zmconv_microp feature +Github PR URL: https://github.com/ESCOMP/CAM/pull/890 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Work to make ZM compatible with CCPP conversion process + - Removed CAM3 switch from ZM in move to no longer support CAM3 + - Remove microphysics embedded in ZM: https://github.com/ESCOMP/CAM/issues/889 + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: + - removed zmconv_microp namelist + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume, mwaxmonsky + +List all files eliminated: +D src/physics/cam/zm_microphysics.F90 + - removed zmconv_microp capability as it is not used + +D src/physics/cam/zm_conv.F90 + - moved ZM to ESCOMP/atcmospheric_physics and broke into separate modules + +D cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/shell_commands +D cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_cam +D cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_clm +D cime_config/testdefs/testmods_dirs/cam/outfrq3s_convmic/user_nl_cpl + - removed test which tested zmconv_microp + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M Externals_CAM.cfg + - updated ESCOMP/atmospheric_physics to bring in tag with ZM + +M bld/build-namelist +M bld/namelist_files/namelist_defaults_cam.xml +M bld/namelist_files/namelist_definition.xml +M src/physics/cam/clubb_intr.F90 + - removed zmconv_microp namelist and associated code + +M bld/configure + - add location for src/atmos_phys/zm + +M cime_config/testdefs/testlist_cam.xml + - removed test which tested zmconv_microp and CAM3 + +M src/physics/cam/macrop_driver.F90 + - removed zmconv_microp namelist and associated code + - Changes needed to support ZM no longer having pcols dimension + +M src/chemistry/modal_aero/modal_aero_convproc.F90 +M src/physics/cam/cloud_fraction.F90 +M src/physics/cam/convect_shallow.F90 +M src/physics/cam/rk_stratiform.F90 +M src/physics/spcam/crmclouds_camaerosols.F90 + - Changes needed to support ZM no longer having pcols dimension + +M src/physics/cam/zm_conv_intr.F90 + - Changes to prepare this routine to support CCPP conversion + - Pass in variables which were being "use"d in ZM previously + - Only pass :ncol sections of arrays since pcols has been removed from ZM + - removed zmconv_microp namelist and associated code + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: all BFB except: + ERP_Ln9_Vnuopc.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: PEND) details: + ERP_Ln9_Vnuopc.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - preexisting failures + +izumi/nag/aux_cam: all BFB except: + DAE_Vnuopc.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - preexisting failure + +izumi/gnu/aux_cam: all BFB + +=============================================================== +=============================================================== + Tag name: cam6_3_145 Originator(s): katetc, cacraigucar, andrewgettelman Date: 05 Jan 2024 diff --git a/src/chemistry/modal_aero/modal_aero_convproc.F90 b/src/chemistry/modal_aero/modal_aero_convproc.F90 index 3d13ed52e3..6c8b7cd441 100644 --- a/src/chemistry/modal_aero/modal_aero_convproc.F90 +++ b/src/chemistry/modal_aero/modal_aero_convproc.F90 @@ -532,7 +532,7 @@ subroutine ma_convproc_dp_intr( & integer :: i integer :: itmpveca(pcols) - integer :: l, lchnk, lun + integer :: l, lchnk, lun, ncol integer :: nstep real(r8) :: dpdry(pcols,pver) ! layer delta-p-dry (mb) @@ -565,6 +565,7 @@ subroutine ma_convproc_dp_intr( & ! Initialize lchnk = state%lchnk + ncol = state%ncol nstep = get_nstep() lun = iulog @@ -587,6 +588,7 @@ subroutine ma_convproc_dp_intr( & call pbuf_get_field(pbuf, zm_ideep_idx, ideep) lengath = count(ideep > 0) + if (lengath > ncol) lengath = ncol ! should not happen, but force it to not be larger than ncol for safety sake fracice(:,:) = 0.0_r8 diff --git a/src/physics/cam/cloud_fraction.F90 b/src/physics/cam/cloud_fraction.F90 index 365da98f50..3285862fae 100644 --- a/src/physics/cam/cloud_fraction.F90 +++ b/src/physics/cam/cloud_fraction.F90 @@ -751,10 +751,10 @@ subroutine cldfrc_fice(ncol, t, fice, fsnow) ! Arguments integer, intent(in) :: ncol ! number of active columns - real(r8), intent(in) :: t(pcols,pver) ! temperature + real(r8), intent(in) :: t(:,:) ! temperature - real(r8), intent(out) :: fice(pcols,pver) ! Fractional ice content within cloud - real(r8), intent(out) :: fsnow(pcols,pver) ! Fractional snow content for convection + real(r8), intent(out) :: fice(:,:) ! Fractional ice content within cloud + real(r8), intent(out) :: fsnow(:,:) ! Fractional snow content for convection ! Local variables real(r8) :: tmax_fice ! max temperature for cloud ice formation diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index bb38481e39..1432be7327 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -4,17 +4,17 @@ module clubb_intr ! Module to interface CAM with Cloud Layers Unified by Bi-normals (CLUBB), developed ! ! by the University of Wisconsin Milwaukee Group (UWM). ! ! ! - ! CLUBB replaces the exisiting turbulence, shallow convection, and macrophysics in CAM5 ! - ! ! + ! CLUBB replaces the exisiting turbulence, shallow convection, and macrophysics in CAM5 ! + ! ! ! Lastly, a implicit diffusion solver is called, and tendencies retrieved by ! ! differencing the diffused and initial states. ! - ! ! + ! ! ! Calling sequence: ! ! ! !---------------------------Code history-------------------------------------------------------------- ! - ! Authors: P. Bogenschutz, C. Craig, A. Gettelman ! - ! Modified by: K Thayer-Calder ! - ! ! + ! Authors: P. Bogenschutz, C. Craig, A. Gettelman ! + ! Modified by: K Thayer-Calder ! + ! ! !----------------------------------------------------------------------------------------------------- ! use shr_kind_mod, only: r8=>shr_kind_r8 @@ -24,11 +24,10 @@ module clubb_intr use air_composition, only: rairv, cpairv use cam_history_support, only: max_fieldname_len - use spmd_utils, only: masterproc - use constituents, only: pcnst, cnst_add - use pbl_utils, only: calc_ustar, calc_obklen - use ref_pres, only: top_lev => trop_cloud_top_lev - use zm_conv_intr, only: zmconv_microp + use spmd_utils, only: masterproc + use constituents, only: pcnst, cnst_add + use pbl_utils, only: calc_ustar, calc_obklen + use ref_pres, only: top_lev => trop_cloud_top_lev #ifdef CLUBB_SGS use clubb_api_module, only: pdf_parameter, implicit_coefs_terms use clubb_api_module, only: clubb_config_flags_type, grid, stats, nu_vertical_res_dep @@ -46,7 +45,7 @@ module clubb_intr stats_rad_zt(pcols), & ! stats_rad_zt grid stats_rad_zm(pcols), & ! stats_rad_zm grid stats_sfc(pcols) ! stats_sfc - + !$omp threadprivate(stats_zt, stats_zm, stats_rad_zt, stats_rad_zm, stats_sfc) #endif @@ -64,7 +63,7 @@ module clubb_intr stats_init_clubb, & stats_zt, stats_zm, stats_sfc, & stats_rad_zt, stats_rad_zm, & - stats_end_timestep_clubb, & + stats_end_timestep_clubb, & #endif clubb_readnl, & clubb_init_cnst, & @@ -89,7 +88,7 @@ module clubb_intr integer, parameter :: & grid_type = 3, & ! The 2 option specifies stretched thermodynamic levels hydromet_dim = 0 ! The hydromet array in SAM-CLUBB is currently 0 elements - + ! Even though sclr_dim is set to 0, the dimension here is set to 1 to prevent compiler errors ! See github ticket larson-group/cam#133 for details real(r8), parameter, dimension(1) :: & @@ -101,28 +100,28 @@ module clubb_intr theta0 = 300._r8, & ! Reference temperature [K] ts_nudge = 86400._r8, & ! Time scale for u/v nudging (not used) [s] p0_clubb = 100000._r8 - - integer, parameter :: & + + integer, parameter :: & sclr_dim = 0 ! Higher-order scalars, set to zero real(r8), parameter :: & wp3_const = 1._r8 ! Constant to add to wp3 when moments are advected - - real(r8), parameter :: & + + real(r8), parameter :: & wpthlp_const = 10.0_r8 ! Constant to add to wpthlp when moments are advected - - real(r8), parameter :: & + + real(r8), parameter :: & wprtp_const = 0.01_r8 ! Constant to add to wprtp when moments are advected - - real(r8), parameter :: & + + real(r8), parameter :: & rtpthlp_const = 0.01_r8 ! Constant to add to rtpthlp when moments are advected - + real(r8), parameter :: unset_r8 = huge(1.0_r8) integer, parameter :: unset_i = huge(1) - ! Commonly used temperature for the melting temp of ice crystals [K] - real(r8), parameter :: meltpt_temp = 268.15_r8 - + ! Commonly used temperature for the melting temp of ice crystals [K] + real(r8), parameter :: meltpt_temp = 268.15_r8 + real(r8) :: clubb_timestep = unset_r8 ! Default CLUBB timestep, unless overwriten by namelist real(r8) :: clubb_rnevap_effic = unset_r8 @@ -178,7 +177,7 @@ module clubb_intr real(r8) :: clubb_detliq_rad = unset_r8 real(r8) :: clubb_detice_rad = unset_r8 real(r8) :: clubb_detphase_lowtemp = unset_r8 - + integer :: & clubb_iiPDF_type, & ! Selected option for the two-component normal ! (double Gaussian) PDF type to use for the w, rt, @@ -190,7 +189,7 @@ module clubb_intr clubb_tridiag_solve_method = unset_i ! Specifier for method to solve tri-diagonal systems - + logical :: & clubb_l_use_precip_frac, & ! Flag to use precipitation fraction in KK microphysics. The ! precipitation fraction is automatically set to 1 when this @@ -253,8 +252,8 @@ module clubb_intr ! that is linearized in terms of wp3. ! (Requires ADG1 PDF and clubb_l_standard_term_ta). clubb_l_godunov_upwind_wpxp_ta, & ! This flag determines whether we want to use an upwind - ! differencing approximation rather than a centered - ! differencing for turbulent advection terms. + ! differencing approximation rather than a centered + ! differencing for turbulent advection terms. ! It affects wpxp only. clubb_l_godunov_upwind_xpyp_ta, & ! This flag determines whether we want to use an upwind ! differencing approximation rather than a centered @@ -311,9 +310,9 @@ module clubb_intr logical, parameter, private :: & l_implemented = .true., & ! Implemented in a host model (always true) l_host_applies_sfc_fluxes = .false. ! Whether the host model applies the surface fluxes - + logical, parameter, private :: & - apply_to_heat = .false. ! Apply WACCM energy fixer to heat or not (.true. = yes (duh)) + apply_to_heat = .false. ! Apply WACCM energy fixer to heat or not (.true. = yes (duh)) logical :: lq(pcnst) logical :: prog_modal_aero @@ -326,8 +325,8 @@ module clubb_intr integer :: history_budget_histfile_num integer :: edsclr_dim ! Number of scalars to transport in CLUBB integer :: offset - -! define physics buffer indicies here + +! define physics buffer indicies here integer :: & wp2_idx, & ! vertical velocity variances wp3_idx, & ! third moment of vertical velocity @@ -386,8 +385,8 @@ module clubb_intr naai_idx, & ! ice number concentration prer_evap_idx, & ! rain evaporation rate qrl_idx, & ! longwave cooling rate - radf_idx, & - qsatfac_idx, & ! subgrid cloud water saturation scaling factor + radf_idx, & + qsatfac_idx, & ! subgrid cloud water saturation scaling factor ice_supersat_idx, & ! ice cloud fraction for SILHS rcm_idx, & ! Cloud water mixing ratio for SILHS ztodt_idx,& ! physics timestep for SILHS @@ -408,7 +407,7 @@ module clubb_intr pdf_zm_varnce_w_2_idx, & pdf_zm_mixt_frac_idx - integer, public :: & + integer, public :: & ixthlp2 = 0, & ixwpthlp = 0, & ixwprtp = 0, & @@ -427,7 +426,7 @@ module clubb_intr dnlfzm_idx = -1, & ! ZM detrained convective cloud water num concen. dnifzm_idx = -1 ! ZM detrained convective cloud ice num concen. - ! Output arrays for CLUBB statistics + ! Output arrays for CLUBB statistics real(r8), allocatable, dimension(:,:,:) :: out_zt, out_zm, out_radzt, out_radzm, out_sfc character(len=16) :: eddy_scheme ! Default set in phys_control.F90 @@ -441,14 +440,14 @@ module clubb_intr #ifdef CLUBB_SGS type(pdf_parameter), target, allocatable, public, protected :: & pdf_params_chnk(:) ! PDF parameters (thermo. levs.) [units vary] - + type(pdf_parameter), target, allocatable :: pdf_params_zm_chnk(:) ! PDF parameters on momentum levs. [units vary] - + type(implicit_coefs_terms), target, allocatable :: pdf_implicit_coefs_terms_chnk(:) ! PDF impl. coefs. & expl. terms [units vary] #endif contains - + ! =============================================================================== ! ! ! ! =============================================================================== ! @@ -473,7 +472,7 @@ subroutine clubb_register_cam( ) !----- Begin Code ----- call phys_getopts( eddy_scheme_out = eddy_scheme, & - deep_scheme_out = deep_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) @@ -489,7 +488,7 @@ subroutine clubb_register_cam( ) cnst_names =(/'THLP2 ','RTP2 ','RTPTHLP','WPTHLP ','WPRTP ','WP2 ','WP3 ','UP2 ','VP2 '/) do_cnst=.true. ! If CLUBB moments are advected, do not output them automatically which is typically done. Some moments - ! need a constant added to them before they are advected, thus this would corrupt the output. + ! need a constant added to them before they are advected, thus this would corrupt the output. ! Users should refer to the "XXXX_CLUBB" (THLP2_CLUBB for instance) output variables for these moments call cnst_add(trim(cnst_names(1)),0._r8,0._r8,0._r8,ixthlp2,longname='second moment vertical velocity',cam_outfld=.false.) call cnst_add(trim(cnst_names(2)),0._r8,0._r8,0._r8,ixrtp2,longname='second moment rtp',cam_outfld=.false.) @@ -522,7 +521,7 @@ subroutine clubb_register_cam( ) 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('WP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wp2_idx) call pbuf_add_field('WP3_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wp3_idx) call pbuf_add_field('WPTHLP_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wpthlp_idx) @@ -531,7 +530,7 @@ subroutine clubb_register_cam( ) call pbuf_add_field('RTP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), rtp2_idx) call pbuf_add_field('THLP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), thlp2_idx) call pbuf_add_field('UP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), up2_idx) - call pbuf_add_field('VP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), vp2_idx) + call pbuf_add_field('VP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), vp2_idx) call pbuf_add_field('RTP3', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), rtp3_idx) call pbuf_add_field('THLP3', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), thlp3_idx) @@ -577,7 +576,7 @@ 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) -#endif +#endif end subroutine clubb_register_cam ! =============================================================================== ! @@ -601,14 +600,14 @@ function clubb_implements_cnst(name) end function clubb_implements_cnst - + ! =============================================================================== ! ! ! ! =============================================================================== ! subroutine clubb_init_cnst(name, latvals, lonvals, mask, q) #ifdef CLUBB_SGS - use clubb_api_module, only: w_tol_sqd, rt_tol, thl_tol + use clubb_api_module, only: w_tol_sqd, rt_tol, thl_tol #endif !----------------------------------------------------------------------- ! @@ -681,7 +680,7 @@ subroutine clubb_init_cnst(name, latvals, lonvals, mask, q) end subroutine clubb_init_cnst - + ! =============================================================================== ! ! ! ! =============================================================================== ! @@ -695,7 +694,7 @@ subroutine clubb_readnl(nlfile) use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_logical, mpi_real8, & mpi_integer use clubb_mf, only: clubb_mf_readnl - + use clubb_api_module, only: & set_default_clubb_config_flags_api, & ! Procedure(s) initialize_clubb_config_flags_type_api, & @@ -708,7 +707,7 @@ subroutine clubb_readnl(nlfile) character(len=*), parameter :: sub = 'clubb_readnl' - logical :: clubb_history = .false., clubb_rad_history = .false. ! Stats enabled (T/F) + logical :: clubb_history = .false., clubb_rad_history = .false. ! Stats enabled (T/F) logical :: clubb_cloudtop_cooling = .false., clubb_rainevap_turb = .false. integer :: iunit, read_status, ierr @@ -746,7 +745,7 @@ subroutine clubb_readnl(nlfile) clubb_C_invrs_tau_N2_wpxp, & clubb_C_invrs_tau_N2_xp2, & clubb_c_K1, & - clubb_c_K10, & + clubb_c_K10, & clubb_c_K10h, & clubb_c_K2, & clubb_c_K8, & @@ -815,13 +814,13 @@ subroutine clubb_readnl(nlfile) !----- Begin Code ----- - ! Determine if we want clubb_history to be output + ! Determine if we want clubb_history to be output clubb_history = .false. ! Initialize to false l_stats = .false. ! Initialize to false l_output_rad_files = .false. ! Initialize to false do_cldcool = .false. ! Initialize to false do_rainturb = .false. ! Initialize to false - + ! Initialize namelist variables to clubb defaults call set_default_clubb_config_flags_api( clubb_iiPDF_type, & ! Out clubb_ipdf_call_placement, & ! Out @@ -969,7 +968,7 @@ subroutine clubb_readnl(nlfile) call mpi_bcast(clubb_c_K10, 1, mpi_real8, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_c_K10") call mpi_bcast(clubb_c_K10h, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_c_K10h") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_c_K10h") call mpi_bcast(clubb_beta, 1, mpi_real8, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_beta") call mpi_bcast(clubb_C2rt, 1, mpi_real8, mstrid, mpicom, ierr) @@ -1017,21 +1016,21 @@ subroutine clubb_readnl(nlfile) call mpi_bcast(clubb_do_energyfix, 1, mpi_logical, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_do_energyfix") call mpi_bcast(clubb_C_invrs_tau_bkgnd, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_bkgnd") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_bkgnd") call mpi_bcast(clubb_C_invrs_tau_sfc, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_sfc") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_sfc") call mpi_bcast(clubb_C_invrs_tau_shear, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_shear") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_shear") call mpi_bcast(clubb_C_invrs_tau_N2, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_N2") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_N2") call mpi_bcast(clubb_C_invrs_tau_N2_wp2, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_N2_wp2") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_N2_wp2") call mpi_bcast(clubb_C_invrs_tau_N2_xp2, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_N2_xp2") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_N2_xp2") call mpi_bcast(clubb_C_invrs_tau_N2_wpxp, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_N2_wpxp") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_N2_wpxp") call mpi_bcast(clubb_C_invrs_tau_N2_clear_wp3, 1, mpi_real8, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_N2_clear_wp3") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_invrs_tau_N2_clear_wp3") call mpi_bcast(clubb_lmin_coef, 1, mpi_real8, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_lmin_coef") call mpi_bcast(clubb_skw_max_mag, 1, mpi_real8, mstrid, mpicom, ierr) @@ -1130,10 +1129,10 @@ subroutine clubb_readnl(nlfile) ! Overwrite defaults if they are true if (clubb_history) l_stats = .true. - if (clubb_rad_history) l_output_rad_files = .true. + if (clubb_rad_history) l_output_rad_files = .true. if (clubb_cloudtop_cooling) do_cldcool = .true. if (clubb_rainevap_turb) do_rainturb = .true. - + ! Check that all namelists have been set if(clubb_timestep == unset_r8) call endrun(sub//": FATAL: clubb_timestep is not set") if(clubb_rnevap_effic == unset_r8) call endrun(sub//": FATAL:clubb_rnevap_effic is not set") @@ -1193,7 +1192,7 @@ subroutine clubb_readnl(nlfile) if(clubb_detphase_lowtemp == unset_r8) call endrun(sub//": FATAL: clubb_detphase_lowtemp not set") if(clubb_penta_solve_method == unset_i) call endrun(sub//": FATAL: clubb_penta_solve_method not set") if(clubb_tridiag_solve_method == unset_i) call endrun(sub//": FATAL: clubb_tridiag_solve_method not set") - if(clubb_detphase_lowtemp >= meltpt_temp) & + if(clubb_detphase_lowtemp >= meltpt_temp) & call endrun(sub//": ERROR: clubb_detphase_lowtemp must be less than 268.15 K") call initialize_clubb_config_flags_type_api( clubb_iiPDF_type, & ! In @@ -1243,7 +1242,7 @@ subroutine clubb_readnl(nlfile) clubb_l_e3sm_config, & ! In clubb_l_vary_convect_depth, & ! In clubb_l_use_tke_in_wp3_pr_turb_term, & ! In - clubb_l_use_tke_in_wp2_wp3_K_dfsn, & ! In + clubb_l_use_tke_in_wp2_wp3_K_dfsn, & ! In clubb_l_smooth_Heaviside_tau_wpxp, & ! In clubb_l_enable_relaxed_clipping, & ! In clubb_l_linearize_pbl_winds, & ! In @@ -1336,7 +1335,7 @@ subroutine clubb_ini_cam(pbuf2d) #ifdef CLUBB_SGS real(kind=time_precision) :: dum1, dum2, dum3 - + ! The similar name to clubb_history is unfortunate... logical :: history_amwg, history_clubb @@ -1389,10 +1388,10 @@ subroutine clubb_ini_cam(pbuf2d) pdf_implicit_coefs_terms_chnk(begchunk:endchunk) ) ! ----------------------------------------------------------------- ! - ! Determine how many constituents CLUBB will transport. Note that - ! CLUBB does not transport aerosol consituents. Therefore, need to + ! Determine how many constituents CLUBB will transport. Note that + ! CLUBB does not transport aerosol consituents. Therefore, need to ! determine how many aerosols constituents there are and subtract that - ! off of pcnst (the total consituents) + ! off of pcnst (the total consituents) ! ----------------------------------------------------------------- ! call phys_getopts(prog_modal_aero_out=prog_modal_aero, & @@ -1401,7 +1400,7 @@ subroutine clubb_ini_cam(pbuf2d) do_hb_above_clubb_out=do_hb_above_clubb) ! Select variables to apply tendencies back to CAM - + ! Initialize all consituents to true to start lq(1:pcnst) = .true. edsclr_dim = pcnst @@ -1415,12 +1414,12 @@ subroutine clubb_ini_cam(pbuf2d) if (prog_modal_aero) then ! Turn off modal aerosols and decrement edsclr_dim accordingly call rad_cnst_get_info(0, nmodes=nmodes) - + do m = 1, nmodes call rad_cnst_get_mode_num_idx(m, lptr) lq(lptr)=.false. edsclr_dim = edsclr_dim-1 - + call rad_cnst_get_info(0, m, nspec=nspec) do l = 1, nspec call rad_cnst_get_mam_mmr_idx(m, l, lptr) @@ -1428,7 +1427,7 @@ subroutine clubb_ini_cam(pbuf2d) edsclr_dim = edsclr_dim-1 end do end do - + ! In addition, if running with MAM, droplet number is transported ! in dropmixnuc, therefore we do NOT want CLUBB to apply transport ! tendencies to avoid double counted. Else, we apply tendencies. @@ -1452,7 +1451,7 @@ subroutine clubb_ini_cam(pbuf2d) l_stats_samp = .false. l_grads = .false. - ! Overwrite defaults if needbe + ! Overwrite defaults if needbe if (l_stats) l_stats_samp = .true. ! Define physics buffers indexes @@ -1461,7 +1460,7 @@ subroutine clubb_ini_cam(pbuf2d) ast_idx = pbuf_get_index('AST') ! Stratiform cloud fraction alst_idx = pbuf_get_index('ALST') ! Liquid stratiform cloud fraction aist_idx = pbuf_get_index('AIST') ! Ice stratiform cloud fraction - qlst_idx = pbuf_get_index('QLST') ! Physical in-stratus LWC + qlst_idx = pbuf_get_index('QLST') ! Physical in-stratus LWC 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 @@ -1483,26 +1482,19 @@ subroutine clubb_ini_cam(pbuf2d) iiedsclr_thl = -1 iiedsclr_CO2 = -1 - if (zmconv_microp) then - dlfzm_idx = pbuf_get_index('DLFZM') - difzm_idx = pbuf_get_index('DIFZM') - dnlfzm_idx = pbuf_get_index('DNLFZM') - dnifzm_idx = pbuf_get_index('DNIFZM') - end if - ! ----------------------------------------------------------------- ! ! Define number of tracers for CLUBB to diffuse - ! ----------------------------------------------------------------- ! - + ! ----------------------------------------------------------------- ! + if (clubb_l_do_expldiff_rtm_thlm) then offset = 2 ! diffuse temperature and moisture explicitly - edsclr_dim = edsclr_dim + offset + edsclr_dim = edsclr_dim + offset endif - + ! ----------------------------------------------------------------- ! ! Setup CLUBB core ! ----------------------------------------------------------------- ! - + ! Read in parameters for CLUBB. Just read in default values call set_default_parameters_api( & C1, C1b, C1c, C2rt, C2thl, C2rtthl, & @@ -1606,7 +1598,7 @@ subroutine clubb_ini_cam(pbuf2d) clubb_params(iC_invrs_tau_N2_xp2) = clubb_C_invrs_tau_N2_xp2 clubb_params(iC_invrs_tau_N2_wpxp) = clubb_C_invrs_tau_N2_wpxp clubb_params(iC_invrs_tau_N2_clear_wp3) = clubb_C_invrs_tau_N2_clear_wp3 - + ! Set up CLUBB core. Note that some of these inputs are overwritten ! when clubb_tend_cam is called. The reason is that heights can change ! at each time step, which is why dummy arrays are read in here for heights @@ -1647,7 +1639,7 @@ subroutine clubb_ini_cam(pbuf2d) write(iulog,'(a,i0,a)') " CLUBB configurable flags " call print_clubb_config_flags_api( iulog, clubb_config_flags ) ! Intent(in) end if - + ! ----------------------------------------------------------------- ! ! Add output fields for the history files ! ----------------------------------------------------------------- ! @@ -1675,7 +1667,7 @@ subroutine clubb_ini_cam(pbuf2d) call addfld ('WPRCP_CLUBB', (/ 'ilev' /), 'A', 'W/m2', 'Liquid Water Flux') call addfld ('CLOUDFRAC_CLUBB', (/ 'lev' /), 'A', 'fraction', 'Cloud Fraction') call addfld ('RCMINLAYER_CLUBB', (/ 'lev' /), 'A', 'kg/kg', 'Cloud Water in Layer') - call addfld ('CLOUDCOVER_CLUBB', (/ 'lev' /), 'A', 'fraction', 'Cloud Cover') + call addfld ('CLOUDCOVER_CLUBB', (/ 'lev' /), 'A', 'fraction', 'Cloud Cover') call addfld ('WPTHVP_CLUBB', (/ 'ilev' /), 'A', 'W/m2', 'Buoyancy Flux') call addfld ('RVMTEND_CLUBB', (/ 'lev' /), 'A', 'kg/kg /s', 'Water vapor tendency') call addfld ('STEND_CLUBB', (/ 'lev' /), 'A', 'J/(kg s)', 'Static energy tendency') @@ -1684,7 +1676,7 @@ subroutine clubb_ini_cam(pbuf2d) call addfld ('UTEND_CLUBB', (/ 'lev' /), 'A', 'm/s /s', 'U-wind Tendency') call addfld ('VTEND_CLUBB', (/ 'lev' /), 'A', 'm/s /s', 'V-wind Tendency') call addfld ('ZT_CLUBB', (/ 'lev' /), 'A', 'm', 'Thermodynamic Heights') - call addfld ('ZM_CLUBB', (/ 'ilev' /), 'A', 'm', 'Momentum Heights') + call addfld ('ZM_CLUBB', (/ 'ilev' /), 'A', 'm', 'Momentum Heights') call addfld ('UM_CLUBB', (/ 'lev' /), 'A', 'm/s', 'Zonal Wind') call addfld ('VM_CLUBB', (/ 'lev' /), 'A', 'm/s', 'Meridional Wind') call addfld ('WM_ZT_CLUBB', (/ 'lev' /), 'A', 'm/s', 'Vertical Velocity') @@ -1702,8 +1694,8 @@ subroutine clubb_ini_cam(pbuf2d) call addfld ('FQTENDICE', (/ 'lev' /), 'A', 'fraction', 'Frequency of Ice Saturation Adjustment') call addfld ('DPDLFLIQ', (/ 'lev' /), 'A', 'kg/kg/s', 'Detrained liquid water from deep convection') - call addfld ('DPDLFICE', (/ 'lev' /), 'A', 'kg/kg/s', 'Detrained ice from deep convection') - call addfld ('DPDLFT', (/ 'lev' /), 'A', 'K/s', 'T-tendency due to deep convective detrainment') + call addfld ('DPDLFICE', (/ 'lev' /), 'A', 'kg/kg/s', 'Detrained ice from deep convection') + call addfld ('DPDLFT', (/ 'lev' /), 'A', 'K/s', 'T-tendency due to deep convective detrainment') call addfld ('RELVAR', (/ 'lev' /), 'A', '-', 'Relative cloud water variance') call addfld ('CLUBB_GRID_SIZE', horiz_only, 'A', 'm', 'Horizontal grid box size seen by CLUBB') @@ -1743,7 +1735,7 @@ subroutine clubb_ini_cam(pbuf2d) call addfld ( 'edmf_S_AWV' , (/ 'ilev' /), 'A', 'm2/s2' , 'Sum of a_i*w_i*v_i (EDMF)' ) call addfld ( 'edmf_thlflx' , (/ 'ilev' /), 'A', 'W/m2' , 'thl flux (EDMF)' ) call addfld ( 'edmf_qtflx' , (/ 'ilev' /), 'A', 'W/m2' , 'qt flux (EDMF)' ) - end if + end if ! Initialize statistics, below are dummy variables dum1 = 300._r8 @@ -1751,13 +1743,13 @@ subroutine clubb_ini_cam(pbuf2d) dum3 = 300._r8 if (l_stats) then - + do i=1, pcols call stats_init_clubb( .true., dum1, dum2, & nlev+1, nlev+1, nlev+1, dum3, & stats_zt(i), stats_zm(i), stats_sfc(i), & stats_rad_zt(i), stats_rad_zm(i)) - end do + end do allocate(out_zt(pcols,pverp,stats_zt(1)%num_output_fields)) allocate(out_zm(pcols,pverp,stats_zm(1)%num_output_fields)) @@ -1767,12 +1759,12 @@ subroutine clubb_ini_cam(pbuf2d) allocate(out_radzm(pcols,pverp,stats_rad_zm(1)%num_output_fields)) endif - + ! ----------------------------------------------------------------- ! ! Make all of this output default, this is not CLUBB history ! ----------------------------------------------------------------- ! - - if (clubb_do_adv .or. history_clubb) then + + if (clubb_do_adv .or. history_clubb) then call add_default('RELVAR', 1, ' ') call add_default('RHO_CLUBB', 1, ' ') call add_default('UP2_CLUBB', 1, ' ') @@ -1805,14 +1797,14 @@ subroutine clubb_ini_cam(pbuf2d) call add_default('UTEND_CLUBB', 1, ' ') call add_default('VTEND_CLUBB', 1, ' ') call add_default('ZT_CLUBB', 1, ' ') - call add_default('ZM_CLUBB', 1, ' ') + call add_default('ZM_CLUBB', 1, ' ') call add_default('UM_CLUBB', 1, ' ') call add_default('VM_CLUBB', 1, ' ') call add_default('WM_ZT_CLUBB', 1, ' ') call add_default('PBLH', 1, ' ') call add_default('CONCLD', 1, ' ') endif - + if (history_amwg) then call add_default('PBLH', 1, ' ') end if @@ -1841,10 +1833,10 @@ subroutine clubb_ini_cam(pbuf2d) call add_default( 'edmf_qtflx' , 1, ' ') end if - if (history_budget) then + if (history_budget) then call add_default('DPDLFLIQ', history_budget_histfile_num, ' ') call add_default('DPDLFICE', history_budget_histfile_num, ' ') - call add_default('DPDLFT', history_budget_histfile_num, ' ') + call add_default('DPDLFT', history_budget_histfile_num, ' ') call add_default('STEND_CLUBB', history_budget_histfile_num, ' ') call add_default('RCMTEND_CLUBB', history_budget_histfile_num, ' ') call add_default('RIMTEND_CLUBB', history_budget_histfile_num, ' ') @@ -1852,7 +1844,7 @@ subroutine clubb_ini_cam(pbuf2d) call add_default('UTEND_CLUBB', history_budget_histfile_num, ' ') call add_default('VTEND_CLUBB', history_budget_histfile_num, ' ') endif - + ! --------------- ! ! First step? ! @@ -1871,12 +1863,12 @@ subroutine clubb_ini_cam(pbuf2d) call pbuf_set_field(pbuf2d, thlp2_idx, thl_tol**2) call pbuf_set_field(pbuf2d, up2_idx, w_tol_sqd) call pbuf_set_field(pbuf2d, vp2_idx, w_tol_sqd) - + call pbuf_set_field(pbuf2d, rtp3_idx, 0.0_r8) call pbuf_set_field(pbuf2d, thlp3_idx, 0.0_r8) call pbuf_set_field(pbuf2d, up3_idx, 0.0_r8) call pbuf_set_field(pbuf2d, vp3_idx, 0.0_r8) - + call pbuf_set_field(pbuf2d, upwp_idx, 0.0_r8) call pbuf_set_field(pbuf2d, vpwp_idx, 0.0_r8) call pbuf_set_field(pbuf2d, wpthvp_idx, 0.0_r8) @@ -1914,10 +1906,10 @@ subroutine clubb_ini_cam(pbuf2d) call pbuf_set_field(pbuf2d, pdf_zm_mixt_frac_idx, 0.0_r8) endif - + ! The following is physpkg, so it needs to be initialized every time call pbuf_set_field(pbuf2d, fice_idx, 0.0_r8) - + ! --------------- ! ! End ! ! Initialization ! @@ -1925,19 +1917,19 @@ subroutine clubb_ini_cam(pbuf2d) #endif end subroutine clubb_ini_cam - - + + ! =============================================================================== ! ! ! ! =============================================================================== ! subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & - cmfmc, cam_in, & + cmfmc, cam_in, & macmic_it, cld_macmic_num_steps,dlf, det_s, det_ice) !------------------------------------------------------------------------------- - ! Description: Provide tendencies of shallow convection, turbulence, and + ! Description: Provide tendencies of shallow convection, turbulence, and ! macrophysics from CLUBB to CAM - ! + ! ! Author: Cheryl Craig, March 2011 ! Modifications: Pete Bogenschutz, March 2011 and onward ! Origin: Based heavily on UWM clubb_init.F90 @@ -1954,7 +1946,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & use constituents, only: cnst_get_ind, cnst_type use camsrfexch, only: cam_in_t - use time_manager, only: is_first_step + use time_manager, only: is_first_step use cam_abortutils, only: endrun use cam_logfile, only: iulog use tropopause, only: tropopause_findChemTrop @@ -1997,13 +1989,13 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & use macrop_driver, only: liquid_macro_tend use clubb_mf, only: integrate_mf - + use perf_mod #endif implicit none - + ! ---------------------------------------------------- ! ! Input Auguments ! ! ---------------------------------------------------- ! @@ -2015,11 +2007,11 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & real(r8), intent(in) :: cmfmc(pcols,pverp) ! convective mass flux--m sub c [kg/m2/s] integer, intent(in) :: cld_macmic_num_steps ! number of mac-mic iterations integer, intent(in) :: macmic_it ! number of mac-mic iterations - + ! ---------------------------------------------------- ! ! Input-Output Auguments ! ! ---------------------------------------------------- ! - + type(physics_buffer_desc), pointer :: pbuf(:) ! ---------------------------------------------------- ! @@ -2028,11 +2020,11 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & type(physics_ptend), intent(out) :: ptend_all ! package tendencies - ! These two variables are needed for energy check + ! These two variables are needed for energy check real(r8), intent(out) :: det_s(pcols) ! Integral of detrained static energy from ice real(r8), intent(out) :: det_ice(pcols) ! Integral of detrained ice for energy check - + ! ---------------------------------------------------- ! ! Local Variables ! ! ---------------------------------------------------- ! @@ -2041,26 +2033,26 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & type(physics_state) :: state1 ! Local copy of state variable type(physics_ptend) :: ptend_loc ! Local tendency from processes, added up to return as ptend_all - + integer :: i, j, k, t, ixind, nadv integer :: ixcldice, ixcldliq, ixnumliq, ixnumice, ixq integer :: itim_old integer :: ncol, lchnk ! # of columns, and chunk identifier integer :: err_code ! Diagnostic, for if some calculation goes amiss. - integer :: icnt + integer :: icnt logical :: lq2(pcnst) integer :: iter - + integer :: clubbtop(pcols) - + real(r8) :: frac_limit, ic_limit - real(r8) :: dtime ! CLUBB time step [s] - real(r8) :: zt_out(pcols,pverp) ! output for the thermo CLUBB grid [m] + real(r8) :: dtime ! CLUBB time step [s] + real(r8) :: zt_out(pcols,pverp) ! output for the thermo CLUBB grid [m] real(r8) :: zi_out(pcols,pverp) ! output for momentum CLUBB grid [m] real(r8) :: ubar ! surface wind [m/s] - real(r8) :: ustar ! surface stress [m/s] + real(r8) :: ustar ! surface stress [m/s] real(r8) :: z0 ! roughness height [m] real(r8) :: bflx22(pcols) ! Variable for buoyancy flux for pbl [K m/s] real(r8) :: qclvar(pcols,pverp) ! cloud water variance [kg^2/kg^2] @@ -2080,7 +2072,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & upwp_sfc_pert, & ! perturbed u'w' at surface [m^2/s^2] vpwp_sfc_pert, & ! perturbed v'w' at surface [m^2/s^2] grid_dx, grid_dy ! CAM grid [m] - + real(r8), dimension(state%ncol,sclr_dim) :: & wpsclrp_sfc ! Scalar flux at surface [{units vary} m/s] @@ -2091,7 +2083,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! NOTE: THESE VARIABLS SHOULD NOT BE USED IN PBUF OR OUTFLD (HISTORY) SUBROUTINES real(r8), dimension(state%ncol,pverp+1-top_lev) :: & thlm_forcing, & ! theta_l forcing (thermodynamic levels) [K/s] - rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s] + rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s] um_forcing, & ! u wind forcing (thermodynamic levels) [m/s/s] vm_forcing, & ! v wind forcing (thermodynamic levels) [m/s/s] wprtp_forcing, & @@ -2166,7 +2158,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & rcm_in_layer_out, & ! CLUBB output of in-cloud liq. wat. mix. ratio [kg/kg] cloud_cover_out, & ! CLUBB output of in-cloud cloud fraction [fraction] invrs_tau_zm_out, & ! CLUBB output of 1 divided by time-scale [1/s] - rtp2_mc_out, & ! total water tendency from rain evap + rtp2_mc_out, & ! total water tendency from rain evap thlp2_mc_out, & ! thetal tendency from rain evap wprtp_mc_out, & wpthlp_mc_out, & @@ -2197,7 +2189,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & sclrprtp, & ! sclr'rt' (momentum levels) [{units vary} (kg/kg)] sclrpthlp, & ! sclr'thlp' (momentum levels) [{units vary} (K)] wpsclrp ! w'sclr' (momentum levels) [{units vary} m/s] - + real(r8), dimension(state%ncol,pverp,sclr_dim) :: & sclrpthvp_inout ! sclr'th_v' (momentum levels) [{units vary} (K)] @@ -2242,7 +2234,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & real(r8) :: pdfp_rtp2(pcols, pverp) ! Calculated R-tot variance from pdf_params [kg^2/kg^2] real(r8) :: rtp2_zt_out(pcols, pverp) ! CLUBB R-tot variance on thermo levs [kg^2/kg^2] real(r8) :: thl2_zt_out(pcols, pverp) ! CLUBB Theta-l variance on thermo levs - real(r8) :: wp2_zt_out(pcols, pverp) + real(r8) :: wp2_zt_out(pcols, pverp) real(r8) :: dlf_liq_out(pcols, pverp) ! Detrained liquid water from ZM [kg/kg/s] real(r8) :: dlf_ice_out(pcols, pverp) ! Detrained ice water from ZM [kg/kg/s] real(r8) :: wm_zt_out(pcols, pverp) ! CLUBB mean W on thermo levs output [m/s] @@ -2272,7 +2264,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! ---------------------------------------------------- ! ! Pointers ! ! ---------------------------------------------------- ! - + real(r8), pointer, dimension(:,:) :: wp2 ! vertical velocity variance [m^2/s^2] real(r8), pointer, dimension(:,:) :: wp3 ! third moment of vertical velocity [m^3/s^3] real(r8), pointer, dimension(:,:) :: wpthlp ! turbulent flux of thetal [m/s K] @@ -2322,16 +2314,16 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & real(r8), pointer, dimension(:,:) :: qlst ! Physical in-stratus LWC [kg/kg] real(r8), pointer, dimension(:,:) :: qist ! Physical in-stratus IWC [kg/kg] real(r8), pointer, dimension(:,:) :: deepcu ! deep convection cloud fraction [fraction] - real(r8), pointer, dimension(:,:) :: shalcu ! shallow convection cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: shalcu ! shallow convection cloud fraction [fraction] real(r8), pointer, dimension(:,:) :: khzm ! CLUBB's eddy diffusivity of heat/moisture on momentum (i.e. interface) levels [m^2/s] 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(:,:) :: ice_supersat_frac ! Cloud fraction of ice clouds (pverp)[fraction] + 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 [-] real(r8), pointer, dimension(:,:) :: naai - real(r8), pointer, dimension(:,:) :: cmeliq + real(r8), pointer, dimension(:,:) :: cmeliq real(r8), pointer, dimension(:,:) :: cmfmc_sh ! Shallow convective mass flux--m subc (pcols,pverp) [kg/m2/s/] real(r8), pointer, dimension(:,:) :: qsatfac @@ -2413,13 +2405,13 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & intrinsic :: max character(len=*), parameter :: subr='clubb_tend_cam' - + type(grid) :: gr integer :: begin_height, end_height - + type(nu_vertical_res_dep) :: nu_vert_res_dep ! Vertical resolution dependent nu values real(r8) :: lmin - + #endif det_s(:) = 0.0_r8 det_ice(:) = 0.0_r8 @@ -2440,7 +2432,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & pdfp_rtp2 = 0._r8 wm_zt_out = 0._r8 - temp2d = 0._r8 + temp2d = 0._r8 temp2dp = 0._r8 dl_rad = clubb_detliq_rad @@ -2451,7 +2443,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ic_limit = 1.e-12_r8 inv_rh2o = 1._r8/rh2o - if (clubb_do_adv) then + if (clubb_do_adv) then apply_const = 1._r8 ! Initialize to one, only if CLUBB's moments are advected else apply_const = 0._r8 ! Never want this if CLUBB's moments are not advected @@ -2488,7 +2480,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! Determine time step of physics buffer itim_old = pbuf_old_tim_idx() - ! Establish associations between pointers and physics buffer fields + ! Establish associations between pointers and physics buffer fields call pbuf_get_field(pbuf, wp2_idx, wp2, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) call pbuf_get_field(pbuf, wp3_idx, wp3, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) call pbuf_get_field(pbuf, wpthlp_idx, wpthlp, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) @@ -2533,7 +2525,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call pbuf_get_field(pbuf, rtm_idx, rtm, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) call pbuf_get_field(pbuf, um_idx, um, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) call pbuf_get_field(pbuf, vm_idx, vm, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) - + call pbuf_get_field(pbuf, tke_idx, tke) call pbuf_get_field(pbuf, qrl_idx, qrl) call pbuf_get_field(pbuf, radf_idx, radf_clubb) @@ -2567,13 +2559,13 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call pbuf_get_field(pbuf, wprtp_mc_zt_idx, wprtp_mc_zt) call pbuf_get_field(pbuf, wpthlp_mc_zt_idx, wpthlp_mc_zt) call pbuf_get_field(pbuf, rtpthlp_mc_zt_idx, rtpthlp_mc_zt) - + ! Allocate pdf_params only if they aren't allocated already. if ( .not. allocated(pdf_params_chnk(lchnk)%mixt_frac) ) then call init_pdf_params_api( pverp+1-top_lev, ncol, pdf_params_chnk(lchnk) ) call init_pdf_params_api( pverp+1-top_lev, ncol, pdf_params_zm_chnk(lchnk) ) end if - + if ( .not. allocated(pdf_implicit_coefs_terms_chnk(lchnk)%coef_wp4_implicit) ) then call init_pdf_implicit_coefs_terms_api( pverp+1-top_lev, ncol, sclr_dim, & pdf_implicit_coefs_terms_chnk(lchnk) ) @@ -2581,15 +2573,15 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! Initialize the apply_const variable (note special logic is due to eularian backstepping) if (clubb_do_adv .and. (is_first_step() .or. all(wpthlp(1:ncol,1:pver) == 0._r8))) then - apply_const = 0._r8 ! On first time through do not remove constant - ! from moments since it has not been added yet + apply_const = 0._r8 ! On first time through do not remove constant + ! from moments since it has not been added yet endif ! Set the ztodt timestep in pbuf for SILHS ztodtptr(:) = 1.0_r8*hdtime ! Define the grid box size. CLUBB needs this information to determine what - ! the maximum length scale should be. This depends on the column for + ! the maximum length scale should be. This depends on the column for ! variable mesh grids and lat-lon grids if (single_column) then ! If single column specify grid box size to be something @@ -2597,7 +2589,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & grid_dx(:) = 100000._r8 grid_dy(:) = 100000._r8 else - + call grid_size(state1, grid_dx, grid_dy) end if @@ -2612,11 +2604,11 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & lq2(1) = .TRUE. lq2(ixcldice) = .TRUE. lq2(ixnumice) = .TRUE. - + latsub = latvap + latice - + call physics_ptend_init(ptend_loc, state%psetcols, 'iceadj', ls=.true., lq=lq2 ) - + stend(:ncol,:)=0._r8 qvtend(:ncol,:)=0._r8 qitend(:ncol,:)=0._r8 @@ -2630,9 +2622,9 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! update local copy of state with the tendencies ptend_loc%q(:ncol,top_lev:pver,1)=qvtend(:ncol,top_lev:pver) - ptend_loc%q(:ncol,top_lev:pver,ixcldice)=qitend(:ncol,top_lev:pver) + ptend_loc%q(:ncol,top_lev:pver,ixcldice)=qitend(:ncol,top_lev:pver) ptend_loc%q(:ncol,top_lev:pver,ixnumice)=initend(:ncol,top_lev:pver) - ptend_loc%s(:ncol,top_lev:pver)=stend(:ncol,top_lev:pver) + ptend_loc%s(:ncol,top_lev:pver)=stend(:ncol,top_lev:pver) ! Add the ice tendency to the output tendency call physics_ptend_sum(ptend_loc, ptend_all, ncol) @@ -2646,56 +2638,56 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call outfld( 'QVTENDICE', qvtend, pcols, lchnk ) call outfld( 'QITENDICE', qitend, pcols, lchnk ) call outfld( 'NITENDICE', initend, pcols, lchnk ) - + endif ! Determine CLUBB time step and make it sub-step friendly - ! For now we want CLUBB time step to be 5 min since that is + ! For now we want CLUBB time step to be 5 min since that is ! what has been scientifically validated. However, there are certain - ! instances when a 5 min time step will not be possible (based on + ! instances when a 5 min time step will not be possible (based on ! host model time step or on macro-micro sub-stepping - dtime = clubb_timestep - - ! Now check to see if dtime is greater than the host model - ! (or sub stepped) time step. If it is, then simply - ! set it equal to the host (or sub step) time step. + dtime = clubb_timestep + + ! Now check to see if dtime is greater than the host model + ! (or sub stepped) time step. If it is, then simply + ! set it equal to the host (or sub step) time step. ! This section is mostly to deal with small host model - ! time steps (or small sub-steps) + ! time steps (or small sub-steps) if (dtime > hdtime) then dtime = hdtime endif - + ! Now check to see if CLUBB time step divides evenly into ! the host model time step. If not, force it to divide evenly. ! We also want it to be 5 minutes or less. This section is ! mainly for host model time steps that are not evenly divisible - ! by 5 minutes + ! by 5 minutes if (mod(hdtime,dtime) .ne. 0) then dtime = hdtime/2._r8 - do while (dtime > clubb_timestep) + do while (dtime > clubb_timestep) dtime = dtime/2._r8 end do - endif + endif ! If resulting host model time step and CLUBB time step do not divide evenly - ! into each other, have model throw a fit. + ! into each other, have model throw a fit. if (mod(hdtime,dtime) .ne. 0) then call endrun(subr//': CLUBB time step and HOST time step NOT compatible') endif - - ! determine number of timesteps CLUBB core should be advanced, - ! host time step divided by CLUBB time step + + ! determine number of timesteps CLUBB core should be advanced, + ! host time step divided by CLUBB time step nadv = max(hdtime/dtime,1._r8) - - ! Initialize forcings for transported scalars to zero + + ! Initialize forcings for transported scalars to zero sclrm_forcing(:,:,:) = 0._r8 edsclrm_forcing(:,:,:) = 0._r8 sclrm(:,:,:) = 0._r8 - + ! Compute inverse exner function consistent with CLUBB's definition, which uses a constant - ! surface pressure. CAM's exner (in state) does not. Therefore, for consistent - ! treatment with CLUBB code, anytime exner is needed to treat CLUBB variables + ! surface pressure. CAM's exner (in state) does not. Therefore, for consistent + ! treatment with CLUBB code, anytime exner is needed to treat CLUBB variables ! (such as thlm), use "inv_exner_clubb" otherwise use the exner in state do k=1,pver do i=1,ncol @@ -2709,8 +2701,8 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & inv_exner_clubb_surf(i) = 1._r8/((state1%pmid(i,pver)/p0_clubb)**(rairv(i,pver,lchnk)/cpairv(i,pver,lchnk))) enddo - ! At each CLUBB call, initialize mean momentum and thermo CLUBB state - ! from the CAM state + ! At each CLUBB call, initialize mean momentum and thermo CLUBB state + ! from the CAM state do k=1,pver ! loop over levels do i=1,ncol ! loop over columns @@ -2723,11 +2715,11 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & * inv_exner_clubb(i,k) if (clubb_do_adv) then - if (macmic_it == 1) then + if (macmic_it == 1) then - ! Note that some of the moments below can be positive or negative. - ! Remove a constant that was added to prevent dynamics from clipping - ! them to prevent dynamics from making them positive. + ! Note that some of the moments below can be positive or negative. + ! Remove a constant that was added to prevent dynamics from clipping + ! them to prevent dynamics from making them positive. thlp2(i,k) = state1%q(i,k,ixthlp2) rtp2(i,k) = state1%q(i,k,ixrtp2) rtpthlp(i,k) = state1%q(i,k,ixrtpthlp) - (rtpthlp_const*apply_const) @@ -2742,23 +2734,23 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & enddo enddo - + if (clubb_do_adv) then - ! If not last step of macmic loop then set apply_const back to - ! zero to prevent output from being corrupted. - if (macmic_it == cld_macmic_num_steps) then - apply_const = 1._r8 + ! If not last step of macmic loop then set apply_const back to + ! zero to prevent output from being corrupted. + if (macmic_it == cld_macmic_num_steps) then + apply_const = 1._r8 else apply_const = 0._r8 endif - endif + endif rtm(1:ncol,pverp) = rtm(1:ncol,pver) um(1:ncol,pverp) = state1%u(1:ncol,pver) vm(1:ncol,pverp) = state1%v(1:ncol,pver) thlm(1:ncol,pverp) = thlm(1:ncol,pver) - - if (clubb_do_adv) then + + if (clubb_do_adv) then thlp2(1:ncol,pverp) = thlp2(1:ncol,pver) rtp2(1:ncol,pverp) = rtp2(1:ncol,pver) rtpthlp(1:ncol,pverp) = rtpthlp(1:ncol,pver) @@ -2770,7 +2762,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & vp2(1:ncol,pverp) = vp2(1:ncol,pver) endif - ! Compute virtual potential temperature, which is needed for CLUBB + ! Compute virtual potential temperature, which is needed for CLUBB do k=1,pver do i=1,ncol thv(i,k) = state1%t(i,k)*inv_exner_clubb(i,k)*(1._r8+zvir*state1%q(i,k,ixq)& @@ -2808,24 +2800,24 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & mf_thlflx_output(:,:) = 0._r8 mf_qtflx_output(:,:) = 0._r8 end if - + call t_startf("clubb_tend_cam_i_loop") ! Determine Coriolis force at given latitude. This is never used ! when CLUBB is implemented in a host model, therefore just set ! to zero. - fcor(:) = 0._r8 + fcor(:) = 0._r8 ! Define the CLUBB momentum grid (in height, units of m) do k=1, nlev+1 - do i=1, ncol + do i=1, ncol zi_g(i,k) = state1%zi(i,pverp-k+1)-state1%zi(i,pver+1) - end do + end do end do ! Define the CLUBB thermodynamic grid (in units of m) do k=1, nlev - do i=1, ncol + do i=1, ncol zt_g(i,k+1) = state1%zm(i,pver-k+1)-state1%zi(i,pver+1) end do end do @@ -2835,18 +2827,18 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & dz_g(i,k) = state1%zi(i,k)-state1%zi(i,k+1) ! compute thickness end do end do - - ! Thermodynamic ghost point is below surface + + ! Thermodynamic ghost point is below surface do i=1, ncol zt_g(i,1) = -1._r8*zt_g(i,2) end do - + do i=1, ncol ! Set the elevation of the surface sfc_elevation(i) = state1%zi(i,pver+1) end do - ! Compute thermodynamic stuff needed for CLUBB on thermo levels. + ! Compute thermodynamic stuff needed for CLUBB on thermo levels. ! Inputs for the momentum levels are set below setup_clubb core do k=1,nlev do i=1, ncol @@ -2855,7 +2847,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & invrs_rho_ds_zt(i,k+1) = 1._r8/(rho_ds_zt(i,k+1)) ! full state (moist) variables - p_in_Pa(i,k+1) = state1%pmid(i,pver-k+1) + p_in_Pa(i,k+1) = state1%pmid(i,pver-k+1) exner(i,k+1) = 1._r8/inv_exner_clubb(i,pver-k+1) thv(i,k+1) = state1%t(i,pver-k+1)*inv_exner_clubb(i,pver-k+1)*(1._r8+zvir*state1%q(i,pver-k+1,ixq) & -state1%q(i,pver-k+1,ixcldliq)) @@ -2864,13 +2856,13 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! exception - setting this to moist thv thv_ds_zt(i,k+1) = thv(i,k+1) - rfrzm(i,k+1) = state1%q(i,pver-k+1,ixcldice) + rfrzm(i,k+1) = state1%q(i,pver-k+1,ixcldice) radf(i,k+1) = radf_clubb(i,pver-k+1) qrl_clubb(i,k+1) = qrl(i,pver-k+1)/(cpairv(i,k,lchnk)*state1%pdeldry(i,pver-k+1)) end do end do - - ! Compute mean w wind on thermo grid, convert from omega to w + + ! Compute mean w wind on thermo grid, convert from omega to w do k=1,nlev do i=1,ncol wm_zt(i,k+1) = -1._r8*(state1%omega(i,pver-k+1)-state1%omega(i,pver))/(rho_zt(i,k+1)*gravit) @@ -2892,8 +2884,8 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & qrl_clubb(i,1) = qrl_clubb(i,2) wm_zt(i,1) = wm_zt(i,2) end do - - + + ! ------------------------------------------------- ! ! Begin case specific code for SCAM cases. ! ! This section of code block is NOT called in ! @@ -2911,21 +2903,21 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! Compute surface wind (ubar) ubar = sqrt(um(1,pver)**2+vm(1,pver)**2) if (ubar < 0.25_r8) ubar = 0.25_r8 - + ! Below denotes case specifics for surface momentum ! and thermodynamic fluxes, depending on the case - ! Define ustar (based on case, if not variable) + ! Define ustar (based on case, if not variable) ustar = 0.25_r8 ! Initialize ustar in case no case - + if(trim(scm_clubb_iop_name) == 'BOMEX_5day') then ustar = 0.28_r8 endif - + if(trim(scm_clubb_iop_name) == 'ATEX_48hr') then ustar = 0.30_r8 endif - + if(trim(scm_clubb_iop_name) == 'RICO_3day') then ustar = 0.28_r8 endif @@ -2933,23 +2925,23 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & if(trim(scm_clubb_iop_name) == 'arm97' .or. trim(scm_clubb_iop_name) == 'gate' .or. & trim(scm_clubb_iop_name) == 'toga' .or. trim(scm_clubb_iop_name) == 'mpace' .or. & trim(scm_clubb_iop_name) == 'ARM_CC') then - + bflx22(1) = (gravit/theta0)*wpthlp_sfc(1) - ustar = diag_ustar(zt_g(1,2),bflx22(1),ubar,zo(1)) + ustar = diag_ustar(zt_g(1,2),bflx22(1),ubar,zo(1)) endif - - ! Compute the surface momentum fluxes, if this is a SCAM simulation + + ! Compute the surface momentum fluxes, if this is a SCAM simulation upwp_sfc(1) = -um(1,pver)*ustar**2/ubar vpwp_sfc(1) = -vm(1,pver)*ustar**2/ubar - + end if - ! Define surface sources for transported variables for diffusion, will + ! Define surface sources for transported variables for diffusion, will ! be zero as these tendencies are done in vertical_diffusion do ixind=1,edsclr_dim do i=1,ncol wpedsclrp_sfc(i,ixind) = 0._r8 - end do + end do end do ! Set stats output and increment equal to CLUBB and host dt @@ -2958,10 +2950,10 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & stats_nsamp = nint(stats_tsamp/dtime) stats_nout = nint(stats_tout/dtime) - - ! Heights need to be set at each timestep. Therefore, recall - ! setup_grid and setup_parameters for this. - + + ! Heights need to be set at each timestep. Therefore, recall + ! setup_grid and setup_parameters for this. + ! Set-up CLUBB core at each CLUBB call because heights can change ! Important note: do not make any calls that use CLUBB grid-height ! operators (such as zt2zm_api, etc.) until AFTER the @@ -2994,7 +2986,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & vm_ref(:,:) = 0.0_r8 ug(:,:) = 0.0_r8 vg(:,:) = 0.0_r8 - + ! Add forcings for SILHS covariance contributions rtp2_forcing = zt2zm_api( pverp+1-top_lev, ncol, gr, rtp2_mc_zt(1:ncol,:) ) thlp2_forcing = zt2zm_api( pverp+1-top_lev, ncol, gr, thlp2_mc_zt(1:ncol,:) ) @@ -3008,7 +3000,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & wprtp_mc_zt(:,:) = 0.0_r8 wpthlp_mc_zt(:,:) = 0.0_r8 rtpthlp_mc_zt(:,:) = 0.0_r8 - + ! Compute some inputs from the thermodynamic grid ! to the momentum grid @@ -3017,9 +3009,9 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & invrs_rho_ds_zm = zt2zm_api( pverp+1-top_lev, ncol, gr, invrs_rho_ds_zt ) thv_ds_zm = zt2zm_api( pverp+1-top_lev, ncol, gr, thv_ds_zt ) wm_zm = zt2zm_api( pverp+1-top_lev, ncol, gr, wm_zt ) - + ! Surface fluxes provided by host model - do i=1,ncol + do i=1,ncol wpthlp_sfc(i) = cam_in%shf(i)/(cpairv(i,pver,lchnk)*rho_ds_zm(i,1)) ! Sensible heat flux wpthlp_sfc(i) = wpthlp_sfc(i)*inv_exner_clubb_surf(i) ! Potential temperature flux wprtp_sfc(i) = cam_in%cflx(i,1)/rho_ds_zm(i,1) ! Moisture flux @@ -3035,7 +3027,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call calc_ustar( state1%t(i,pver), state1%pmid(i,pver), cam_in%wsx(i), cam_in%wsy(i), & rrho(i), ustar ) - + upwp_sfc(i) = -state1%u(i,pver)*ustar**2/ubar vpwp_sfc(i) = -state1%v(i,pver)*ustar**2/ubar end do @@ -3049,12 +3041,12 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! Perturbed winds are not used in CAM upwp_sfc_pert = 0.0_r8 vpwp_sfc_pert = 0.0_r8 - + ! Need to flip arrays around for CLUBB core do k=1,nlev+1 do i=1,ncol - um_in(i,k) = um(i,pverp-k+1) - vm_in(i,k) = vm(i,pverp-k+1) + um_in(i,k) = um(i,pverp-k+1) + vm_in(i,k) = vm(i,pverp-k+1) upwp_in(i,k) = upwp(i,pverp-k+1) vpwp_in(i,k) = vpwp(i,pverp-k+1) wpthvp_in(i,k) = wpthvp(i,pverp-k+1) @@ -3113,13 +3105,13 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & vm_pert_inout = 0.0_r8 upwp_pert_inout = 0.0_r8 vpwp_pert_inout = 0.0_r8 - + do k=2,nlev+1 do i=1,ncol pre_in(i,k) = prer_evap(i,pverp-k+1) end do end do - + do i=1,ncol pre_in(i,1) = pre_in(i,2) end do @@ -3127,7 +3119,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & do i=1,ncol rcm_inout(i,1) = rcm_inout(i,2) end do - + ! Initialize these to prevent crashing behavior do k=1,nlev+1 do i=1,ncol @@ -3154,7 +3146,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & end do end do end do - + do ixind=1, hydromet_dim do k=1, nlev+1 do i=1, ncol @@ -3169,7 +3161,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! pressure,exner on momentum grid needed for mass flux calc. if (do_clubb_mf) then - + 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)) @@ -3177,7 +3169,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & invrs_exner_zt(i,k+1) = inv_exner_clubb(i,pver-k+1) end do end do - + do i=1,ncol kappa_zt(i,1) = kappa_zt(i,2) qc_zt(i,1) = qc_zt(i,2) @@ -3185,21 +3177,21 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & end do kappa_zm(1:ncol,:) = zt2zm_api(pverp+1-top_lev, ncol, gr, kappa_zt(1:ncol,:)) - + do k=1,pverp do i=1,ncol p_in_Pa_zm(i,k) = state1%pint(i,pverp-k+1) invrs_exner_zm(i,k) = 1._r8/((p_in_Pa_zm(i,k)/p0_clubb)**(kappa_zm(i,k))) end do end do - + end if - - + + if (clubb_do_adv) then if (macmic_it == 1) then - - wp2_in = zt2zm_api(pverp+1-top_lev, ncol, gr, wp2_in ) + + wp2_in = zt2zm_api(pverp+1-top_lev, ncol, gr, wp2_in ) wpthlp_in = zt2zm_api(pverp+1-top_lev, ncol, gr, wpthlp_in ) wprtp_in = zt2zm_api(pverp+1-top_lev, ncol, gr, wprtp_in ) up2_in = zt2zm_api(pverp+1-top_lev, ncol, gr, up2_in ) @@ -3217,49 +3209,49 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & vp2_in(i,k) = max(w_tol_sqd,vp2_in(i,k)) end do end do - + end if end if - ! Do the same for tracers + ! Do the same for tracers icnt=0 do ixind=1,pcnst - if (lq(ixind)) then - + if (lq(ixind)) then + icnt = icnt+1 - + do k=1,nlev do i=1,ncol edsclr_in(i,k+1,icnt) = state1%q(i,pver-k+1,ixind) end do end do - + do i=1,ncol edsclr_in(i,1,icnt) = edsclr_in(i,2,icnt) end do - + end if end do - - if (clubb_l_do_expldiff_rtm_thlm) then + + if (clubb_l_do_expldiff_rtm_thlm) then do k=1,nlev do i=1, ncol edsclr_in(i,k+1,icnt+1) = thlm(i,pver-k+1) edsclr_in(i,k+1,icnt+2) = rtm(i,pver-k+1) end do end do - + do i=1, ncol edsclr_in(i,1,icnt+1) = edsclr_in(i,2,icnt+1) - edsclr_in(i,1,icnt+2) = edsclr_in(i,2,icnt+2) + edsclr_in(i,1,icnt+2) = edsclr_in(i,2,icnt+2) end do - + endif do t=1,nadv ! do needed number of "sub" timesteps for each CAM step - + ! Increment the statistics then being stats timestep if (l_stats) then call stats_begin_timestep_api(t, stats_nsamp, stats_nout) @@ -3269,18 +3261,18 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & !###################### CALL MF DIAGNOSTIC PLUMES ###################### !####################################################################### if (do_clubb_mf) then - + do k=2,pverp do i=1, ncol dzt(i,k) = zi_g(i,k) - zi_g(i,k-1) end do end do - + do i=1, ncol dzt(i,1) = dzt(i,2) invrs_dzt(i,:) = 1._r8/dzt(i,:) end do - + 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,:) ) @@ -3309,19 +3301,19 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & rtm_forcing(i,1) = 0._r8 thlm_forcing(i,1)= 0._r8 end do - + 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))) - + 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 end if - + ! Advance CLUBB CORE one timestep in the future call advance_clubb_core_api( gr, pverp+1-top_lev, ncol, & l_implemented, dtime, fcor, sfc_elevation, hydromet_dim, & @@ -3363,7 +3355,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & 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 ) - + ! Note that CLUBB does not produce an error code specific to any column, and ! one value only for the entire chunk if ( err_code == clubb_fatal_error ) then @@ -3372,15 +3364,15 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & write(fstderr,*) "LON: Range:", state1%lon(1), " -- ", state1%lon(ncol) call endrun(subr//': Fatal error in CLUBB library') end if - + if (do_rainturb) then - + do k=1,nlev+1 do i=1,ncol - rvm_in(i,k) = rtm_in(i,k) - rcm_inout(i,k) + rvm_in(i,k) = rtm_in(i,k) - rcm_inout(i,k) end do end do - + call update_xp2_mc_api( gr, nlev+1, ncol, dtime, cloud_frac_inout, & rcm_inout, rvm_in, thlm_in, wm_zt, & exner, pre_in, pdf_params_chnk(lchnk), & @@ -3392,35 +3384,35 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & do i=1,ncol dum1 = (1._r8 - cam_in%landfrac(i)) - ! update turbulent moments based on rain evaporation + ! update turbulent moments based on rain evaporation rtp2_in(i,k) = rtp2_in(i,k) + clubb_rnevap_effic * dum1 * rtp2_mc_out(i,k) * dtime - thlp2_in(i,k) = thlp2_in(i,k) + clubb_rnevap_effic * dum1 * thlp2_mc_out(i,k) * dtime + thlp2_in(i,k) = thlp2_in(i,k) + clubb_rnevap_effic * dum1 * thlp2_mc_out(i,k) * dtime wprtp_in(i,k) = wprtp_in(i,k) + clubb_rnevap_effic * dum1 * wprtp_mc_out(i,k) * dtime wpthlp_in(i,k) = wpthlp_in(i,k) + clubb_rnevap_effic * dum1 * wpthlp_mc_out(i,k) * dtime end do end do - - end if - + + end if + if (do_cldcool) then - + rcm_out_zm = zt2zm_api(pverp+1-top_lev, ncol, gr, rcm_inout ) qrl_zm = zt2zm_api(pverp+1-top_lev, ncol, gr, qrl_clubb ) thlp2_rad_out(:,:) = 0._r8 - + do i=1, ncol call calculate_thlp2_rad_api(nlev+1, rcm_out_zm(i,:), thlprcp_out(i,:), qrl_zm(i,:), clubb_params, & thlp2_rad_out(i,:)) end do - + do i=1, ncol thlp2_in(i,:) = thlp2_in(i,:) + thlp2_rad_out(i,:) * dtime thlp2_in(i,:) = max(thl_tol**2,thlp2_in(i,:)) end do - + end if - + ! Check to see if stats should be output, here stats are read into ! output arrays to make them conformable to CAM output if (l_stats) then @@ -3433,16 +3425,16 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & enddo ! end time loop if (clubb_do_adv) then - if (macmic_it == cld_macmic_num_steps) then - - wp2_in = zm2zt_api( pverp+1-top_lev, ncol, gr, wp2_in ) + if (macmic_it == cld_macmic_num_steps) then + + wp2_in = zm2zt_api( pverp+1-top_lev, ncol, gr, wp2_in ) wpthlp_in = zm2zt_api( pverp+1-top_lev, ncol, gr, wpthlp_in ) wprtp_in = zm2zt_api( pverp+1-top_lev, ncol, gr, wprtp_in ) up2_in = zm2zt_api( pverp+1-top_lev, ncol, gr, up2_in ) vp2_in = zm2zt_api( pverp+1-top_lev, ncol, gr, vp2_in ) thlp2_in = zm2zt_api( pverp+1-top_lev, ncol, gr, thlp2_in ) rtp2_in = zm2zt_api( pverp+1-top_lev, ncol, gr, rtp2_in ) - rtpthlp_in = zm2zt_api( pverp+1-top_lev, ncol, gr, rtpthlp_in ) + rtpthlp_in = zm2zt_api( pverp+1-top_lev, ncol, gr, rtpthlp_in ) do k=1,nlev+1 do i=1, ncol @@ -3453,16 +3445,16 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & vp2_in(i,k) = max(w_tol_sqd, vp2_in(i,k)) end do end do - + end if end if - + ! Convert RTP2 and THLP2 to thermo grid for output rtp2_zt = zm2zt_api( pverp+1-top_lev, ncol, gr, rtp2_in ) thl2_zt = zm2zt_api( pverp+1-top_lev, ncol, gr, thlp2_in ) wp2_zt = zm2zt_api( pverp+1-top_lev, ncol, gr, wp2_in ) - ! Arrays need to be "flipped" to CAM grid + ! Arrays need to be "flipped" to CAM grid do k=1, nlev+1 do i=1, ncol um(i,pverp-k+1) = um_in(i,k) @@ -3518,18 +3510,18 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & rtp2_zt_out(i,pverp-k+1) = rtp2_zt(i,k) thl2_zt_out(i,pverp-k+1) = thl2_zt(i,k) wp2_zt_out(i,pverp-k+1) = wp2_zt(i,k) - + end do end do do k=1, nlev+1 do i=1, ncol - + mean_rt = pdf_params_chnk(lchnk)%mixt_frac(i,k) & * pdf_params_chnk(lchnk)%rt_1(i,k) & + ( 1.0_r8 - pdf_params_chnk(lchnk)%mixt_frac(i,k) ) & * pdf_params_chnk(lchnk)%rt_2(i,k) - + pdfp_rtp2(i,pverp-k+1) = pdf_params_chnk(lchnk)%mixt_frac(i,k) & * ( ( pdf_params_chnk(lchnk)%rt_1(i,k) - mean_rt )**2 & + pdf_params_chnk(lchnk)%varnce_rt_1(i,k) ) & @@ -3595,18 +3587,18 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & khzm(i,k) = 0._r8 qclvar(i,k) = 2._r8 end do - end do + end do ! enforce zero tracer tendencies above the top_lev level -- no change icnt=0 do ixind=1,pcnst - if (lq(ixind)) then + if (lq(ixind)) then icnt=icnt+1 - + do i=1, ncol edsclr_out(i,:top_lev-1,icnt) = state1%q(i,:top_lev-1,ixind) end do - + end if end do @@ -3624,7 +3616,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & end do ! Section below is concentrated on energy fixing for conservation. - ! because CLUBB and CAM's thermodynamic variables are different. + ! because CLUBB and CAM's thermodynamic variables are different. ! Initialize clubbtop to top_lev, for finding the highlest level CLUBB is ! active for informing where to apply the energy fixer. @@ -3632,7 +3624,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & clubbtop(i) = top_lev do while ((rtp2(i,clubbtop(i)) <= 1.e-15_r8 .and. rcm(i,clubbtop(i)) == 0._r8) .and. clubbtop(i) < pver) clubbtop(i) = clubbtop(i) + 1 - end do + end do end do ! ! set pbuf field so that HB scheme is only applied above CLUBB top @@ -3648,7 +3640,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ke_a(:) = 0._r8 wv_a(:) = 0._r8 wl_a(:) = 0._r8 - + do k=1,pver do i=1, ncol se_a(i) = se_a(i) + clubb_s(i,k)*state1%pdel(i,k)*rga @@ -3656,14 +3648,14 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & wv_a(i) = wv_a(i) + (rtm(i,k)-rcm(i,k))*state1%pdeldry(i,k)*rga wl_a(i) = wl_a(i) + (rcm(i,k))*state1%pdeldry(i,k)*rga end do - end do - + end do + ! Do the same as above, but for before CLUBB was called. se_b(:) = 0._r8 ke_b(:) = 0._r8 wv_b(:) = 0._r8 - wl_b(:) = 0._r8 - + wl_b(:) = 0._r8 + do k=1, pver do i=1, ncol se_b(i) = se_b(i) + state1%s(i,k)*state1%pdel(i,k)*rga @@ -3672,23 +3664,23 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & wl_b(i) = wl_b(i) + state1%q(i,k,ixcldliq)*state1%pdeldry(i,k)*rga end do end do - - + + do i=1, ncol ! Based on these integrals, compute the total energy before and after CLUBB call te_a(i) = se_a(i) + ke_a(i) + (latvap+latice) * wv_a(i) + latice * wl_a(i) te_b(i) = se_b(i) + ke_b(i) + (latvap+latice) * wv_b(i) + latice * wl_b(i) - + ! Take into account the surface fluxes of heat and moisture ! Use correct qflux from cam_in, not lhf/latvap as was done previously - te_b(i) = te_b(i) + (cam_in%shf(i)+cam_in%cflx(i,1)*(latvap+latice)) * hdtime + te_b(i) = te_b(i) + (cam_in%shf(i)+cam_in%cflx(i,1)*(latvap+latice)) * hdtime ! Compute the disbalance of total energy, over depth where CLUBB is active se_dis(i) = (te_a(i) - te_b(i))/(state1%pint(i,pverp)-state1%pint(i,clubbtop(i))) end do ! Fix the total energy coming out of CLUBB so it achieves energy conservation. - ! Apply this fixer throughout the column evenly, but only at layers where + ! Apply this fixer throughout the column evenly, but only at layers where ! CLUBB is active. ! ! NOTE: The energy fixer seems to cause the climate to change significantly @@ -3704,7 +3696,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & end do endif - + ! Now compute the tendencies of CLUBB to CAM, note that pverp is the ghost point ! for all variables and therefore is never called in this loop do k=1, pver @@ -3718,17 +3710,17 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & end do end do - - + + if (clubb_do_adv) then if (macmic_it == cld_macmic_num_steps) then - + do k=1, pver do i=1, ncol - ! Here add a constant to moments which can be either positive or + ! Here add a constant to moments which can be either positive or ! negative. This is to prevent clipping when dynamics tries to - ! make all constituents positive + ! make all constituents positive wp3(i,k) = wp3(i,k) + wp3_const rtpthlp(i,k) = rtpthlp(i,k) + rtpthlp_const wpthlp(i,k) = wpthlp(i,k) + wpthlp_const @@ -3737,18 +3729,18 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ptend_loc%q(i,k,ixthlp2) = (thlp2(i,k) - state1%q(i,k,ixthlp2)) / hdtime ! THLP Variance ptend_loc%q(i,k,ixrtp2) = (rtp2(i,k) - state1%q(i,k,ixrtp2)) / hdtime ! RTP Variance ptend_loc%q(i,k,ixrtpthlp) = (rtpthlp(i,k) - state1%q(i,k,ixrtpthlp)) / hdtime ! RTP THLP covariance - ptend_loc%q(i,k,ixwpthlp) = (wpthlp(i,k) - state1%q(i,k,ixwpthlp)) / hdtime ! WPTHLP + ptend_loc%q(i,k,ixwpthlp) = (wpthlp(i,k) - state1%q(i,k,ixwpthlp)) / hdtime ! WPTHLP ptend_loc%q(i,k,ixwprtp) = (wprtp(i,k) - state1%q(i,k,ixwprtp)) / hdtime ! WPRTP ptend_loc%q(i,k,ixwp2) = (wp2(i,k) - state1%q(i,k,ixwp2)) / hdtime ! WP2 ptend_loc%q(i,k,ixwp3) = (wp3(i,k) - state1%q(i,k,ixwp3)) / hdtime ! WP3 ptend_loc%q(i,k,ixup2) = (up2(i,k) - state1%q(i,k,ixup2)) / hdtime ! UP2 ptend_loc%q(i,k,ixvp2) = (vp2(i,k) - state1%q(i,k,ixvp2)) / hdtime ! VP2 - + end do end do - + else - + do k=1, pver do i=1, ncol ptend_loc%q(i,k,ixthlp2) = 0._r8 @@ -3759,16 +3751,16 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ptend_loc%q(i,k,ixwp2) = 0._r8 ptend_loc%q(i,k,ixwp3) = 0._r8 ptend_loc%q(i,k,ixup2) = 0._r8 - ptend_loc%q(i,k,ixvp2) = 0._r8 + ptend_loc%q(i,k,ixvp2) = 0._r8 end do end do - + end if end if - + ! Apply tendencies to ice mixing ratio, liquid and ice number, and aerosol constituents. - ! Loading up this array doesn't mean the tendencies are applied. + ! Loading up this array doesn't mean the tendencies are applied. ! edsclr_out is compressed with just the constituents being used, ptend and state are not compressed icnt=0 do ixind=1,pcnst @@ -3779,17 +3771,17 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & (ixind /= ixrtpthlp) .and. (ixind /= ixwpthlp) .and.& (ixind /= ixwprtp) .and. (ixind /= ixwp2) .and.& (ixind /= ixwp3) .and. (ixind /= ixup2) .and. (ixind /= ixvp2) ) then - + do k=1, pver do i=1, ncol - ptend_loc%q(i,k,ixind) = (edsclr_out(i,k,icnt)-state1%q(i,k,ixind))/hdtime ! transported constituents + ptend_loc%q(i,k,ixind) = (edsclr_out(i,k,icnt)-state1%q(i,k,ixind))/hdtime ! transported constituents end do end do - + end if end if end do - + call t_stopf("clubb_tend_cam_i_loop") call outfld('KVH_CLUBB', khzm, pcols, lchnk) @@ -3798,7 +3790,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call outfld('ELEAK_CLUBB', eleak, pcols, lchnk) call outfld('TFIX_CLUBB', se_dis, pcols, lchnk) - ! Add constant to ghost point so that output is not corrupted + ! Add constant to ghost point so that output is not corrupted if (clubb_do_adv) then if (macmic_it == cld_macmic_num_steps) then wp3(:,pverp) = wp3(:,pverp) + wp3_const @@ -3806,7 +3798,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & wpthlp(:,pverp) = wpthlp(:,pverp) + wpthlp_const wprtp(:,pverp) = wprtp(:,pverp) + wprtp_const end if - end if + end if ! ------------------------------------------------- ! ! End column computation of CLUBB, begin to apply ! @@ -3832,32 +3824,32 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call physics_ptend_sum(ptend_loc,ptend_all,ncol) call physics_update(state1,ptend_loc,hdtime) - - ! Due to the order of operation of CLUBB, which closes on liquid first, - ! then advances it's predictive equations second, this can lead to - ! RHliq > 1 directly before microphysics is called. Therefore, we use - ! ice_macro_tend to enforce RHliq <= 1 everywhere before microphysics is called. - + + ! Due to the order of operation of CLUBB, which closes on liquid first, + ! then advances it's predictive equations second, this can lead to + ! RHliq > 1 directly before microphysics is called. Therefore, we use + ! ice_macro_tend to enforce RHliq <= 1 everywhere before microphysics is called. + if (clubb_do_liqsupersat) then - + ! -------------------------------------- ! ! Ice Saturation Adjustment Computation ! ! -------------------------------------- ! - + latsub = latvap + latice lq2(:) = .FALSE. lq2(ixq) = .TRUE. lq2(ixcldliq) = .TRUE. lq2(ixnumliq) = .TRUE. - + call physics_ptend_init(ptend_loc, state%psetcols, 'iceadj', ls=.true., lq=lq2 ) - + stend(:ncol,:)=0._r8 qvtend(:ncol,:)=0._r8 qctend(:ncol,:)=0._r8 inctend(:ncol,:)=0._r8 - + call liquid_macro_tend(npccn(1:ncol,top_lev:pver), state1%t(1:ncol,top_lev:pver), & state1%pmid(1:ncol,top_lev:pver), state1%q(1:ncol,top_lev:pver,ixq), & state1%q(1:ncol,top_lev:pver,ixcldliq), state1%q(1:ncol,top_lev:pver,ixnumliq), & @@ -3869,13 +3861,13 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ptend_loc%q(:ncol,top_lev:pver,ixcldliq)=qctend(:ncol,top_lev:pver) ptend_loc%q(:ncol,top_lev:pver,ixnumliq)=inctend(:ncol,top_lev:pver) ptend_loc%s(:ncol,top_lev:pver)=stend(:ncol,top_lev:pver) - + ! Add the ice tendency to the output tendency call physics_ptend_sum(ptend_loc, ptend_all, ncol) - + ! ptend_loc is reset to zero by this call call physics_update(state1, ptend_loc, hdtime) - + ! Write output for tendencies: ! oufld: QVTENDICE,QCTENDICE,NCTENDICE,FQTENDICE temp2d(:ncol,:pver) = stend(:ncol,:pver)/cpairv(:ncol,:pver,lchnk) @@ -3883,25 +3875,25 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call outfld( 'QVTENDICE', qvtend, pcols, lchnk ) call outfld( 'QCTENDICE', qctend, pcols, lchnk ) call outfld( 'NCTENDICE', inctend, pcols, lchnk ) - + where(qctend .ne. 0._r8) fqtend = 1._r8 elsewhere fqtend = 0._r8 end where - + call outfld( 'FQTENDICE', fqtend, pcols, lchnk ) end if - + ! ------------------------------------------------------------ ! ! The rest of the code deals with diagnosing variables ! ! for microphysics/radiation computation and macrophysics ! ! ------------------------------------------------------------ ! - - ! --------------------------------------------------------------------------------- ! + + ! --------------------------------------------------------------------------------- ! ! COMPUTE THE ICE CLOUD DETRAINMENT ! ! Detrainment of convective condensate into the environment or stratiform cloud ! - ! --------------------------------------------------------------------------------- ! + ! --------------------------------------------------------------------------------- ! ! Initialize the shallow convective detrainment rate, will always be zero dlf2(:,:) = 0.0_r8 @@ -3916,13 +3908,6 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call physics_ptend_init(ptend_loc,state%psetcols, 'clubb', ls=.true., lq=lqice) - if (zmconv_microp) then - call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) - call pbuf_get_field(pbuf, difzm_idx, difzm) - call pbuf_get_field(pbuf, dnlfzm_idx, dnlfzm) - call pbuf_get_field(pbuf, dnifzm_idx, dnifzm) - end if - do k=1,pver do i=1,ncol if( state1%t(i,k) > meltpt_temp ) then @@ -3930,35 +3915,24 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & elseif ( state1%t(i,k) < dt_low ) then dum1 = 1.0_r8 else - dum1 = ( meltpt_temp - state1%t(i,k) ) / ( meltpt_temp - dt_low ) + dum1 = ( meltpt_temp - state1%t(i,k) ) / ( meltpt_temp - dt_low ) endif - if (zmconv_microp) then - ptend_loc%q(i,k,ixcldliq) = dlfzm(i,k) + dlf2(i,k) * ( 1._r8 - dum1 ) - ptend_loc%q(i,k,ixcldice) = difzm(i,k) + dlf2(i,k) * dum1 - - ptend_loc%q(i,k,ixnumliq) = dnlfzm(i,k) + 3._r8 * ( dlf2(i,k) * ( 1._r8 - dum1 ) ) & - / (4._r8*3.14_r8*dl_rad**3*997._r8) ! Shallow Convection - ptend_loc%q(i,k,ixnumice) = dnifzm(i,k) + 3._r8 * ( dlf2(i,k) * dum1 ) & - / (4._r8*3.14_r8*di_rad**3*500._r8) ! Shallow Convection - ptend_loc%s(i,k) = dlf2(i,k) * dum1 * latice - else - - ptend_loc%q(i,k,ixcldliq) = dlf(i,k) * ( 1._r8 - dum1 ) - ptend_loc%q(i,k,ixcldice) = dlf(i,k) * dum1 - ptend_loc%q(i,k,ixnumliq) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * ( 1._r8 - dum1 ) ) & + ptend_loc%q(i,k,ixcldliq) = dlf(i,k) * ( 1._r8 - dum1 ) + ptend_loc%q(i,k,ixcldice) = dlf(i,k) * dum1 + ptend_loc%q(i,k,ixnumliq) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * ( 1._r8 - dum1 ) ) & / (4._r8*3.14_r8*dl_rad**3*997._r8) + & ! Deep Convection 3._r8 * ( dlf2(i,k) * ( 1._r8 - dum1 ) ) & - / (4._r8*3.14_r8*10.e-6_r8**3*997._r8) ! Shallow Convection - ptend_loc%q(i,k,ixnumice) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * dum1 ) & + / (4._r8*3.14_r8*10.e-6_r8**3*997._r8) ! Shallow Convection + ptend_loc%q(i,k,ixnumice) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * dum1 ) & / (4._r8*3.14_r8*di_rad**3*500._r8) + & ! Deep Convection 3._r8 * ( dlf2(i,k) * dum1 ) & / (4._r8*3.14_r8*50.e-6_r8**3*500._r8) ! Shallow Convection - ptend_loc%s(i,k) = dlf(i,k) * dum1 * latice + ptend_loc%s(i,k) = dlf(i,k) * dum1 * latice + + dlf_liq_out(i,k) = dlf(i,k) * ( 1._r8 - dum1 ) + dlf_ice_out(i,k) = dlf(i,k) * dum1 - dlf_liq_out(i,k) = dlf(i,k) * ( 1._r8 - dum1 ) - dlf_ice_out(i,k) = dlf(i,k) * dum1 - end if ! convert moist dlf tendencies to dry ptend_loc%q(i,k,ixcldliq) = ptend_loc%q(i,k,ixcldliq)*state1%pdel(i,k)/state1%pdeldry(i,k) ptend_loc%q(i,k,ixcldice) = ptend_loc%q(i,k,ixcldice)*state1%pdel(i,k)/state1%pdeldry(i,k) @@ -3970,20 +3944,20 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & det_ice(i) = det_ice(i) - ptend_loc%q(i,k,ixcldice)*state1%pdeldry(i,k)*rga enddo enddo - + det_ice(:ncol) = det_ice(:ncol)/1000._r8 ! divide by density of water ! output moist basis to be consistent with history variable definition - temp2d(:ncol,:pver) = ptend_loc%q(:ncol,:pver,ixcldliq)*state1%pdeldry(:ncol,:pver)/state1%pdel(:ncol,:pver) + temp2d(:ncol,:pver) = ptend_loc%q(:ncol,:pver,ixcldliq)*state1%pdeldry(:ncol,:pver)/state1%pdel(:ncol,:pver) call outfld( 'DPDLFLIQ', temp2d, pcols, lchnk) ! output moist basis to be consistent with history variable definition temp2d(:ncol,:pver) = ptend_loc%q(:ncol,:pver,ixcldice)*state1%pdeldry(:ncol,:pver)/state1%pdel(:ncol,:pver) call outfld( 'DPDLFICE', temp2d, pcols, lchnk) - + temp2d(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpairv(:ncol,:pver, lchnk) call outfld( 'DPDLFT', temp2d, pcols, lchnk) - + call outfld( 'DETNLIQTND', ptend_loc%q(:,:,ixnumliq),pcols, lchnk ) call physics_ptend_sum(ptend_loc,ptend_all,ncol) @@ -4010,19 +3984,19 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & else relvarmax = 10.0_r8 endif - + relvar(:,:) = relvarmax ! default - if (deep_scheme .ne. 'CLUBB_SGS') then + if (deep_scheme .ne. 'CLUBB_SGS') then where (rcm(:ncol,:pver) /= 0 .and. qclvar(:ncol,:pver) /= 0) & relvar(:ncol,:pver) = min(relvarmax,max(0.001_r8,rcm(:ncol,:pver)**2/qclvar(:ncol,:pver))) endif - + ! ------------------------------------------------- ! ! Optional Accretion enhancement factor ! - ! ------------------------------------------------- ! + ! ------------------------------------------------- ! accre_enhan(:ncol,:pver) = 1._r8 - + ! ------------------------------------------------- ! ! Diagnose some output variables ! ! ------------------------------------------------- ! @@ -4048,7 +4022,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & sl_output(i,k) = cpairv(i,k,lchnk)*state1%t(i,k)+gravit*state1%zm(i,k)-latvap*state1%q(i,k,ixcldliq) enddo enddo - + do k=1,pverp do i=1,ncol wpthlp_output(i,k) = (wpthlp(i,k)-(apply_const*wpthlp_const))*rho(i,k)*cpair ! liquid water potential temperature flux @@ -4062,53 +4036,53 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & end if enddo enddo - - ! --------------------------------------------------------------------------------- ! + + ! --------------------------------------------------------------------------------- ! ! Diagnose some quantities that are computed in macrop_tend here. ! ! These are inputs required for the microphysics calculation. ! ! ! ! FIRST PART COMPUTES THE STRATIFORM CLOUD FRACTION FROM CLUBB CLOUD FRACTION ! - ! --------------------------------------------------------------------------------- ! - - ! initialize variables + ! --------------------------------------------------------------------------------- ! + + ! initialize variables alst(:,:) = 0.0_r8 - qlst(:,:) = 0.0_r8 - + qlst(:,:) = 0.0_r8 + do k=1,pver do i=1,ncol - alst(i,k) = cloud_frac(i,k) + alst(i,k) = cloud_frac(i,k) qlst(i,k) = rcm(i,k)/max(0.01_r8,alst(i,k)) ! Incloud stratus condensate mixing ratio enddo enddo - - ! --------------------------------------------------------------------------------- ! + + ! --------------------------------------------------------------------------------- ! ! THIS PART COMPUTES CONVECTIVE AND DEEP CONVECTIVE CLOUD FRACTION ! - ! --------------------------------------------------------------------------------- ! - + ! --------------------------------------------------------------------------------- ! + deepcu(:,:) = 0.0_r8 shalcu(:,:) = 0.0_r8 - + do k=1,pver-1 do i=1,ncol - ! diagnose the deep convective cloud fraction, as done in macrophysics based on the - ! deep convective mass flux, read in from pbuf. Since shallow convection is never + ! diagnose the deep convective cloud fraction, as done in macrophysics based on the + ! deep convective mass flux, read in from pbuf. Since shallow convection is never ! called, the shallow convective mass flux will ALWAYS be zero, ensuring that this cloud - ! fraction is purely from deep convection scheme. + ! 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 + + ! 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 + ! 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) enddo enddo - + if (single_column) then if (trim(scm_clubb_iop_name) == 'ATEX_48hr' .or. & trim(scm_clubb_iop_name) == 'BOMEX_5day' .or. & @@ -4116,20 +4090,20 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & trim(scm_clubb_iop_name) == 'DYCOMSrf02_06hr' .or. & trim(scm_clubb_iop_name) == 'RICO_3day' .or. & trim(scm_clubb_iop_name) == 'ARM_CC') then - + deepcu(:,:) = 0.0_r8 concld(:,:) = 0.0_r8 - - endif + + endif endif - - ! --------------------------------------------------------------------------------- ! + + ! --------------------------------------------------------------------------------- ! ! COMPUTE THE ICE CLOUD FRACTION PORTION ! ! use the aist_vector function to compute the ice cloud fraction ! - ! --------------------------------------------------------------------------------- ! + ! --------------------------------------------------------------------------------- ! aist(:,:top_lev-1) = 0._r8 - qsatfac(:, :) = 0._r8 ! Zero out entire profile in case qsatfac is left undefined in aist_vector below + qsatfac(:, :) = 0._r8 ! Zero out entire profile in case qsatfac is left undefined in aist_vector below do k = top_lev, pver @@ -4158,37 +4132,37 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & qsatfac_out=qsatfac(:,k), rhmini_in=rhmini, rhmaxi_in=rhmaxi) endif enddo - - ! --------------------------------------------------------------------------------- ! + + ! --------------------------------------------------------------------------------- ! ! THIS PART COMPUTES THE LIQUID STRATUS FRACTION ! ! ! ! For now leave the computation of ice stratus fraction from macrop_driver intact ! - ! because CLUBB does nothing with ice. Here I simply overwrite the liquid stratus ! + ! because CLUBB does nothing with ice. Here I simply overwrite the liquid stratus ! ! fraction that was coded in macrop_driver ! - ! --------------------------------------------------------------------------------- ! - + ! --------------------------------------------------------------------------------- ! + ! Recompute net stratus fraction using maximum over-lapping assumption, as done ! in macrophysics code, using alst computed above and aist read in from physics buffer - + do k=1,pver do i=1,ncol ast(i,k) = max(alst(i,k),aist(i,k)) - qist(i,k) = state1%q(i,k,ixcldice)/max(0.01_r8,aist(i,k)) + qist(i,k) = state1%q(i,k,ixcldice)/max(0.01_r8,aist(i,k)) enddo enddo - - ! Probably need to add deepcu cloud fraction to the cloud fraction array, else would just - ! be outputting the shallow convective cloud fraction + + ! Probably need to add deepcu cloud fraction to the cloud fraction array, else would just + ! 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) enddo enddo - - ! --------------------------------------------------------------------------------- ! + + ! --------------------------------------------------------------------------------- ! ! DIAGNOSE THE PBL DEPTH ! ! this is needed for aerosol code ! - ! --------------------------------------------------------------------------------- ! + ! --------------------------------------------------------------------------------- ! do i=1,ncol do k=1,pver !use local exner since state%exner is not a proper exner @@ -4197,7 +4171,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & thv(i,k) = th(i,k)*(1.0_r8+zvir*state1%q(i,k,ixq) - state1%q(i,k,ixcldliq)) enddo enddo - + ! diagnose surface friction and obukhov length (inputs to diagnose PBL depth) rrho(1:ncol) = (rga)*(state1%pdel(1:ncol,pver)/dz_g(1:ncol,pver)) call calc_ustar( ncol, state1%t(1:ncol,pver), state1%pmid(1:ncol,pver), cam_in%wsx(1:ncol), cam_in%wsy(1:ncol), & @@ -4206,10 +4180,10 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call calc_obklen( ncol, th(1:ncol,pver), thv(1:ncol,pver), cam_in%cflx(1:ncol,1), cam_in%shf(1:ncol), & rrho(1:ncol), ustar2(1:ncol), kinheat(1:ncol), kinwat(1:ncol), kbfs(1:ncol), & obklen(1:ncol)) - + dummy2(:) = 0._r8 dummy3(:) = 0._r8 - + where (kbfs(:ncol) == -0.0_r8) kbfs(:ncol) = 0.0_r8 ! Compute PBL depth according to Holtslag-Boville Scheme @@ -4219,14 +4193,14 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! Output the PBL depth call outfld('PBLH', pblh, pcols, lchnk) - + ! Assign the first pver levels of cloud_frac back to cld cld(:,1:pver) = cloud_frac(:,1:pver) - ! --------------------------------------------------------------------------------- ! + ! --------------------------------------------------------------------------------- ! ! END CLOUD FRACTION DIAGNOSIS, begin to store variables back into buffer ! - ! --------------------------------------------------------------------------------- ! - + ! --------------------------------------------------------------------------------- ! + ! Output calls of variables goes here call outfld( 'RELVAR', relvar, pcols, lchnk ) call outfld( 'RHO_CLUBB', rho(:,1:pver), pcols, lchnk ) @@ -4270,7 +4244,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call outfld( 'CLUBB_GRID_SIZE', grid_dx, pcols, lchnk ) call outfld( 'QSATFAC', qsatfac, pcols, lchnk) - + ! --------------------------------------------------------------- ! ! Writing state variables after EDMF scheme for detailed analysis ! ! --------------------------------------------------------------- ! @@ -4299,44 +4273,44 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & end if ! Output CLUBB history here - if (l_stats) then - + if (l_stats) then + do j=1,stats_zt(1)%num_output_fields - + temp1 = trim(stats_zt(1)%file%grid_avg_var(j)%name) sub = temp1 if (len(temp1) > max_fieldname_len) sub = temp1(1:max_fieldname_len) - + call outfld(trim(sub), out_zt(:,:,j), pcols, lchnk ) enddo - + do j=1,stats_zm(1)%num_output_fields - + temp1 = trim(stats_zm(1)%file%grid_avg_var(j)%name) sub = temp1 if (len(temp1) > max_fieldname_len) sub = temp1(1:max_fieldname_len) - + call outfld(trim(sub),out_zm(:,:,j), pcols, lchnk) enddo - if (l_output_rad_files) then + if (l_output_rad_files) then do j=1,stats_rad_zt(1)%num_output_fields call outfld(trim(stats_rad_zt(1)%file%grid_avg_var(j)%name), out_radzt(:,:,j), pcols, lchnk) enddo - + do j=1,stats_rad_zm(1)%num_output_fields call outfld(trim(stats_rad_zm(1)%file%grid_avg_var(j)%name), out_radzm(:,:,j), pcols, lchnk) enddo endif - + do j=1,stats_sfc(1)%num_output_fields call outfld(trim(stats_sfc(1)%file%grid_avg_var(j)%name), out_sfc(:,:,j), pcols, lchnk) enddo - + endif - + call t_stopf("clubb_tend_cam") - + return #endif end subroutine clubb_tend_cam @@ -4370,7 +4344,7 @@ subroutine clubb_emissions_cam (state, cam_in, ptend) ! --------------- ! ! Local Variables ! ! --------------- ! - integer :: m, ncol + integer :: m, ncol logical :: lq(pcnst) ! ----------------------- ! @@ -4394,7 +4368,7 @@ subroutine clubb_emissions_cam (state, cam_in, ptend) endif end do - end subroutine clubb_emissions_cam + end subroutine clubb_emissions_cam ! =============================================================================== ! ! ! @@ -4402,12 +4376,12 @@ end subroutine clubb_emissions_cam ! Saturation adjustment for ice ! Add ice mass if supersaturated -subroutine ice_macro_tend(naai,t,p,qv,qi,ni,xxls,deltat,stend,qvtend,qitend,nitend,vlen) +subroutine ice_macro_tend(naai,t,p,qv,qi,ni,xxls,deltat,stend,qvtend,qitend,nitend,vlen) use wv_sat_methods, only: wv_sat_qsat_ice integer, intent(in) :: vlen - real(r8), dimension(vlen), intent(in) :: naai !Activated number of ice nuclei + real(r8), dimension(vlen), intent(in) :: naai !Activated number of ice nuclei real(r8), dimension(vlen), intent(in) :: t !temperature (k) real(r8), dimension(vlen), intent(in) :: p !pressure (pa) real(r8), dimension(vlen), intent(in) :: qv !water vapor mixing ratio @@ -4415,11 +4389,11 @@ subroutine ice_macro_tend(naai,t,p,qv,qi,ni,xxls,deltat,stend,qvtend,qitend,nite real(r8), dimension(vlen), intent(in) :: ni !ice number concentration real(r8), intent(in) :: xxls !latent heat of freezing real(r8), intent(in) :: deltat !timestep - real(r8), dimension(vlen), intent(out) :: stend ! 'temperature' tendency + real(r8), dimension(vlen), intent(out) :: stend ! 'temperature' tendency real(r8), dimension(vlen), intent(out) :: qvtend !vapor tendency real(r8), dimension(vlen), intent(out) :: qitend !ice mass tendency - real(r8), dimension(vlen), intent(out) :: nitend !ice number tendency - + real(r8), dimension(vlen), intent(out) :: nitend !ice number tendency + real(r8) :: ESI(vlen) real(r8) :: QSI(vlen) integer :: i @@ -4442,7 +4416,7 @@ subroutine ice_macro_tend(naai,t,p,qv,qi,ni,xxls,deltat,stend,qvtend,qitend,nite qitend(i) = (qv(i)-QSI(i))/deltat qvtend(i) = 0._r8 - qitend(i) stend(i) = qitend(i) * xxls ! moist static energy tend...[J/kg/s] ! - + ! if ice exists (more than 1 L-1) and there is condensation, do not add to number (= growth), else, add 10um ice if (ni(i) < 1.e3_r8 .and. (qi(i)+qitend(i)*deltat) > 1.e-18_r8) then nitend(i) = nitend(i) + 3._r8 * qitend(i)/(4._r8*3.14_r8* 10.e-6_r8**3*997._r8) @@ -4476,7 +4450,7 @@ end subroutine ice_macro_tend ! Code writen March, 1999 by Bjorn Stevens ! -real(r8) function diag_ustar( z, bflx, wnd, z0 ) +real(r8) function diag_ustar( z, bflx, wnd, z0 ) use shr_const_mod, only : shr_const_karman, shr_const_pi, shr_const_g @@ -4545,59 +4519,59 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Description: Initializes the statistics saving functionality of ! the CLUBB model. This is for purpose of CAM-CLUBB interface. Here ! the traditional stats_init of CLUBB is not called, as it is not compatible - ! with CAM output. - + ! with CAM output. + !----------------------------------------------------------------------- use clubb_api_module, only: & - ztscr01, & - ztscr02, & - ztscr03, & - ztscr04, & - ztscr05, & - ztscr06, & - ztscr07, & - ztscr08, & - ztscr09, & - ztscr10, & - ztscr11, & - ztscr12, & - ztscr13, & - ztscr14, & - ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & + ztscr01, & + ztscr02, & + ztscr03, & + ztscr04, & + ztscr05, & + ztscr06, & + ztscr07, & + ztscr08, & + ztscr09, & + ztscr10, & + ztscr11, & + ztscr12, & + ztscr13, & + ztscr14, & + ztscr15, & + ztscr16, & + ztscr17, & + ztscr18, & + ztscr19, & + ztscr20, & ztscr21 use clubb_api_module, only: & - zmscr01, & - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr10, & - zmscr11, & - zmscr12, & - zmscr13, & - zmscr14, & + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + zmscr11, & + zmscr12, & + zmscr13, & + zmscr14, & zmscr15, & zmscr16, & zmscr17, & l_stats, & - l_output_rad_files, & - stats_tsamp, & - stats_tout, & - l_stats_samp, & - l_stats_last, & - l_netcdf, & + l_output_rad_files, & + stats_tsamp, & + stats_tout, & + l_stats_samp, & + l_stats_last, & + l_netcdf, & l_grads use clubb_api_module, only: time_precision, & ! @@ -4619,16 +4593,16 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & logical, intent(in) :: l_stats_in ! Stats on? T/F - real(kind=time_precision), intent(in) :: & + real(kind=time_precision), intent(in) :: & stats_tsamp_in, & ! Sampling interval [s] stats_tout_in ! Output interval [s] integer, intent(in) :: nnzp ! Grid points in the vertical [count] - integer, intent(in) :: nnrad_zt ! Grid points in the radiation grid [count] + integer, intent(in) :: nnrad_zt ! Grid points in the radiation grid [count] integer, intent(in) :: nnrad_zm ! Grid points in the radiation grid [count] real(kind=time_precision), intent(in) :: delt ! Timestep (dtmain in CLUBB) [s] - + ! Output Variables type (stats), intent(out) :: stats_zt, & ! stats_zt grid stats_zm, & ! stats_zm grid @@ -4649,11 +4623,11 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & character(len=var_length), dimension(nvarmax_rad_zm) :: clubb_vars_rad_zm ! Variables on the radiation levels character(len=var_length), dimension(nvarmax_sfc) :: clubb_vars_sfc ! Variables at the model surface - namelist /clubb_stats_nl/ & - clubb_vars_zt, & + namelist /clubb_stats_nl/ & + clubb_vars_zt, & clubb_vars_zm, & clubb_vars_rad_zt, & - clubb_vars_rad_zm, & + clubb_vars_rad_zm, & clubb_vars_sfc ! Local Variables @@ -4671,7 +4645,7 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Set stats_variables variables with inputs from calling subroutine l_stats = l_stats_in - + stats_tsamp = stats_tsamp_in stats_tout = stats_tout_in @@ -4689,7 +4663,7 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & clubb_vars_rad_zm = '' clubb_vars_sfc = '' - ! Read variables to compute from the namelist + ! Read variables to compute from the namelist if (masterproc) then iunit= getunit() open(unit=iunit,file="atm_in",status='old') @@ -4736,8 +4710,8 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Initialize zt (mass points) i = 1 - do while ( ichar(clubb_vars_zt(i)(1:1)) /= 0 .and. & - len_trim(clubb_vars_zt(i)) /= 0 .and. & + do while ( ichar(clubb_vars_zt(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_zt(i)) /= 0 .and. & i <= nvarmax_zt ) i = i + 1 enddo @@ -4821,8 +4795,8 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Initialize zm (momentum points) i = 1 - do while ( ichar(clubb_vars_zm(i)(1:1)) /= 0 .and. & - len_trim(clubb_vars_zm(i)) /= 0 .and. & + do while ( ichar(clubb_vars_zm(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_zm(i)) /= 0 .and. & i <= nvarmax_zm ) i = i + 1 end do @@ -4896,10 +4870,10 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Initialize rad_zt (radiation points) if (l_output_rad_files) then - + i = 1 - do while ( ichar(clubb_vars_rad_zt(i)(1:1)) /= 0 .and. & - len_trim(clubb_vars_rad_zt(i)) /= 0 .and. & + do while ( ichar(clubb_vars_rad_zt(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_rad_zt(i)) /= 0 .and. & i <= nvarmax_rad_zt ) i = i + 1 end do @@ -4932,10 +4906,10 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & stats_rad_zt ) ! Initialize rad_zm (radiation points) - + i = 1 - do while ( ichar(clubb_vars_rad_zm(i)(1:1)) /= 0 .and. & - len_trim(clubb_vars_rad_zm(i)) /= 0 .and. & + do while ( ichar(clubb_vars_rad_zm(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_rad_zm(i)) /= 0 .and. & i <= nvarmax_rad_zm ) i = i + 1 end do @@ -4963,7 +4937,7 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & allocate( stats_rad_zm%file%grid_avg_var( stats_rad_zm%num_output_fields ) ) allocate( stats_rad_zm%file%z( stats_rad_zm%kk ) ) - + call stats_init_rad_zm_api( clubb_vars_rad_zm, l_error, & stats_rad_zm ) end if ! l_output_rad_files @@ -4972,8 +4946,8 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Initialize sfc (surface point) i = 1 - do while ( ichar(clubb_vars_sfc(i)(1:1)) /= 0 .and. & - len_trim(clubb_vars_sfc(i)) /= 0 .and. & + do while ( ichar(clubb_vars_sfc(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_sfc(i)) /= 0 .and. & i <= nvarmax_sfc ) i = i + 1 end do @@ -5015,58 +4989,58 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Now call add fields if (first_call) then - + do i = 1, stats_zt%num_output_fields - + temp1 = trim(stats_zt%file%grid_avg_var(i)%name) sub = temp1 if (len(temp1) > max_fieldname_len) sub = temp1(1:max_fieldname_len) - + call addfld(trim(sub),(/ 'ilev' /),& 'A',trim(stats_zt%file%grid_avg_var(i)%units),trim(stats_zt%file%grid_avg_var(i)%description)) enddo - + do i = 1, stats_zm%num_output_fields - + temp1 = trim(stats_zm%file%grid_avg_var(i)%name) sub = temp1 if (len(temp1) > max_fieldname_len) sub = temp1(1:max_fieldname_len) - + call addfld(trim(sub),(/ 'ilev' /),& 'A',trim(stats_zm%file%grid_avg_var(i)%units),trim(stats_zm%file%grid_avg_var(i)%description)) enddo - if (l_output_rad_files) then + if (l_output_rad_files) then do i = 1, stats_rad_zt%num_output_fields call addfld(trim(stats_rad_zt%file%grid_avg_var(i)%name),(/ 'ilev' /),& 'A',trim(stats_rad_zt%file%grid_avg_var(i)%units),trim(stats_rad_zt%file%grid_avg_var(i)%description)) enddo - + do i = 1, stats_rad_zm%num_output_fields call addfld(trim(stats_rad_zm%file%grid_avg_var(i)%name),(/ 'ilev' /),& 'A',trim(stats_rad_zm%file%grid_avg_var(i)%units),trim(stats_rad_zm%file%grid_avg_var(i)%description)) enddo endif - + do i = 1, stats_sfc%num_output_fields call addfld(trim(stats_sfc%file%grid_avg_var(i)%name),horiz_only,& 'A',trim(stats_sfc%file%grid_avg_var(i)%units),trim(stats_sfc%file%grid_avg_var(i)%description)) enddo - + end if return - end subroutine stats_init_clubb - + end subroutine stats_init_clubb + #endif ! =============================================================================== ! ! ! ! =============================================================================== ! -#ifdef CLUBB_SGS +#ifdef CLUBB_SGS subroutine stats_end_timestep_clubb(thecol, stats_zt, stats_zm, stats_rad_zt, stats_rad_zm, stats_sfc, & out_zt, out_zm, out_radzt, out_radzm, out_sfc) !----------------------------------------------------------------------- @@ -5081,8 +5055,8 @@ subroutine stats_end_timestep_clubb(thecol, stats_zt, stats_zm, stats_rad_zt, st use clubb_api_module, only: & fstderr, & ! Constant(s) - l_stats_last, & - stats_tsamp, & + l_stats_last, & + stats_tsamp, & stats_tout, & l_output_rad_files, & clubb_at_least_debug_level_api ! Procedure(s) @@ -5092,14 +5066,14 @@ subroutine stats_end_timestep_clubb(thecol, stats_zt, stats_zm, stats_rad_zt, st implicit none integer :: thecol - + ! Input Variables type (stats), intent(inout) :: stats_zt, & ! stats_zt grid stats_zm, & ! stats_zm grid stats_rad_zt, & ! stats_rad_zt grid stats_rad_zm, & ! stats_rad_zm grid stats_sfc ! stats_sfc - + ! Inout variables real(r8), intent(inout) :: out_zt(:,:,:) ! (pcols,pverp,stats_zt%num_output_fields) real(r8), intent(inout) :: out_zm(:,:,:) ! (pcols,pverp,stats_zt%num_output_fields) @@ -5130,36 +5104,36 @@ subroutine stats_end_timestep_clubb(thecol, stats_zt, stats_zm, stats_rad_zt, st end if call stats_avg( stats_sfc%kk, stats_sfc%num_output_fields, stats_sfc%accum_field_values, stats_sfc%accum_num_samples ) - ! Here we are not outputting the data, rather reading the stats into + ! Here we are not outputting the data, rather reading the stats into ! arrays which are conformable to CAM output. Also, the data is "flipped" - ! in the vertical level to be the same as CAM output. + ! in the vertical level to be the same as CAM output. do i = 1, stats_zt%num_output_fields - do k = 1, stats_zt%kk + do k = 1, stats_zt%kk out_zt(thecol,pverp-k+1,i) = stats_zt%accum_field_values(1,1,k,i) if(is_nan(out_zt(thecol,k,i))) out_zt(thecol,k,i) = 0.0_r8 - enddo + enddo enddo do i = 1, stats_zm%num_output_fields - do k = 1, stats_zt%kk + do k = 1, stats_zt%kk out_zm(thecol,pverp-k+1,i) = stats_zm%accum_field_values(1,1,k,i) if(is_nan(out_zm(thecol,k,i))) out_zm(thecol,k,i) = 0.0_r8 - enddo + enddo enddo - if (l_output_rad_files) then + if (l_output_rad_files) then do i = 1, stats_rad_zt%num_output_fields - do k = 1, stats_rad_zt%kk + do k = 1, stats_rad_zt%kk out_radzt(thecol,pverp-k+1,i) = stats_rad_zt%accum_field_values(1,1,k,i) if(is_nan(out_radzt(thecol,k,i))) out_radzt(thecol,k,i) = 0.0_r8 - enddo + enddo enddo - + do i = 1, stats_rad_zm%num_output_fields - do k = 1, stats_rad_zm%kk + do k = 1, stats_rad_zm%kk out_radzm(thecol,pverp-k+1,i) = stats_rad_zm%accum_field_values(1,1,k,i) if(is_nan(out_radzm(thecol,k,i))) out_radzm(thecol,k,i) = 0.0_r8 - enddo + enddo enddo ! Fill in values above the CLUBB top. @@ -5169,9 +5143,9 @@ subroutine stats_end_timestep_clubb(thecol, stats_zt, stats_zm, stats_rad_zt, st out_radzm(thecol,:top_lev-1,:) = 0.0_r8 endif ! l_output_rad_files - + do i = 1, stats_sfc%num_output_fields - out_sfc(thecol,1,i) = stats_sfc%accum_field_values(1,1,1,i) + out_sfc(thecol,1,i) = stats_sfc%accum_field_values(1,1,1,i) if(is_nan(out_sfc(thecol,1,i))) out_sfc(thecol,1,i) = 0.0_r8 enddo @@ -5192,14 +5166,14 @@ subroutine stats_end_timestep_clubb(thecol, stats_zt, stats_zm, stats_rad_zt, st return end subroutine stats_end_timestep_clubb -#endif - +#endif + ! =============================================================================== ! ! ! ! =============================================================================== ! #ifdef CLUBB_SGS - + !----------------------------------------------------------------------- subroutine stats_zero( kk, num_output_fields, x, n, l_in_update ) @@ -5233,14 +5207,14 @@ subroutine stats_zero( kk, num_output_fields, x, n, l_in_update ) return end subroutine stats_zero - + #endif ! =============================================================================== ! ! ! ! =============================================================================== ! - + #ifdef CLUBB_SGS !----------------------------------------------------------------------- subroutine stats_avg( kk, num_output_fields, x, n ) @@ -5288,7 +5262,7 @@ subroutine grid_size(state, grid_dx, grid_dy) use shr_const_mod, only: shr_const_pi use physics_types, only: physics_state - + type(physics_state), intent(in) :: state real(r8), intent(out) :: grid_dx(state%ncol), grid_dy(state%ncol) ! CAM grid [m] @@ -5303,17 +5277,17 @@ subroutine grid_size(state, grid_dx, grid_dy) do i=1,state%ncol column_area = get_area_p(state%lchnk,i) degree = sqrt(column_area)*(180._r8/shr_const_pi) - + ! Now find meters per degree latitude ! Below equation finds distance between two points on an ellipsoid, derived from expansion - ! taking into account ellipsoid using World Geodetic System (WGS84) reference + ! taking into account ellipsoid using World Geodetic System (WGS84) reference mpdeglat = earth_ellipsoid1 - earth_ellipsoid2 * cos(2._r8*state%lat(i)) + earth_ellipsoid3 * cos(4._r8*state%lat(i)) grid_dx(i) = mpdeglat * degree grid_dy(i) = grid_dx(i) ! Assume these are the same - enddo + enddo - end subroutine grid_size + end subroutine grid_size #endif - + end module clubb_intr diff --git a/src/physics/cam/convect_shallow.F90 b/src/physics/cam/convect_shallow.F90 index 0fa7e3b83d..ffd1db8f5f 100644 --- a/src/physics/cam/convect_shallow.F90 +++ b/src/physics/cam/convect_shallow.F90 @@ -13,25 +13,26 @@ module convect_shallow use shr_kind_mod, only : r8=>shr_kind_r8 use physconst, only : cpair, zvir use ppgrid, only : pver, pcols, pverp - use zm_conv, only : zm_conv_evap + use zm_conv_evap, only : zm_conv_evap_run + use zm_conv_intr, only : zmconv_ke, zmconv_ke_lnd, zmconv_org use cam_history, only : outfld, addfld, horiz_only use cam_logfile, only : iulog use phys_control, only : phys_getopts implicit none - private + private save public :: & convect_shallow_register, & ! Register fields in physics buffer convect_shallow_init, & ! Initialize shallow module convect_shallow_tend, & ! Return tendencies - convect_shallow_use_shfrc ! + convect_shallow_use_shfrc ! ! The following namelist variable controls which shallow convection package is used. ! 'Hack' = Hack shallow convection (default) ! 'UW' = UW shallow convection by Sungsu Park and Christopher S. Bretherton - ! 'UNICON' = General Convection Model by Sungsu Park + ! 'UNICON' = General Convection Model by Sungsu Park ! 'off' = No shallow convection character(len=16) :: shallow_scheme ! Default set in phys_control.F90, use namelist to change @@ -40,16 +41,16 @@ module convect_shallow logical :: history_budget ! Output tendencies and state variables for CAM4 T, qv, ql, qi integer :: history_budget_histfile_num ! output history file number for budget fields - ! Physics buffer indices - integer :: icwmrsh_idx = 0 - integer :: rprdsh_idx = 0 - integer :: rprdtot_idx = 0 - integer :: cldtop_idx = 0 - integer :: cldbot_idx = 0 - integer :: cush_idx = 0 + ! Physics buffer indices + integer :: icwmrsh_idx = 0 + integer :: rprdsh_idx = 0 + integer :: rprdtot_idx = 0 + integer :: cldtop_idx = 0 + integer :: cldbot_idx = 0 + integer :: cush_idx = 0 integer :: nevapr_shcu_idx = 0 - integer :: shfrc_idx = 0 - integer :: cld_idx = 0 + integer :: shfrc_idx = 0 + integer :: cld_idx = 0 integer :: concld_idx = 0 integer :: rprddp_idx = 0 integer :: tke_idx = 0 @@ -84,9 +85,9 @@ subroutine convect_shallow_register use physics_buffer, only : pbuf_add_field, dtype_r8, dyn_time_lvls use phys_control, only: use_gw_convect_sh use unicon_cam, only: unicon_cam_register - + call phys_getopts( shallow_scheme_out = shallow_scheme, microp_scheme_out = microp_scheme) - + ! SPCAM registers its own fields if (shallow_scheme == 'SPCAM') return @@ -95,7 +96,7 @@ subroutine convect_shallow_register call pbuf_add_field('RPRDTOT', 'physpkg' ,dtype_r8,(/pcols,pver/), rprdtot_idx ) call pbuf_add_field('CLDTOP', 'physpkg' ,dtype_r8,(/pcols,1/), cldtop_idx ) call pbuf_add_field('CLDBOT', 'physpkg' ,dtype_r8,(/pcols,1/), cldbot_idx ) - call pbuf_add_field('cush', 'global' ,dtype_r8,(/pcols,dyn_time_lvls/), cush_idx ) + call pbuf_add_field('cush', 'global' ,dtype_r8,(/pcols,dyn_time_lvls/), cush_idx ) call pbuf_add_field('NEVAPR_SHCU','physpkg' ,dtype_r8,(/pcols,pver/), nevapr_shcu_idx ) call pbuf_add_field('PREC_SH', 'physpkg' ,dtype_r8,(/pcols/), prec_sh_idx ) call pbuf_add_field('SNOW_SH', 'physpkg' ,dtype_r8,(/pcols/), snow_sh_idx ) @@ -110,16 +111,16 @@ subroutine convect_shallow_register endif ! shallow interface gbm flux_convective_cloud_rain+snow (kg/m2/s) - call pbuf_add_field('SH_FLXPRC','physpkg',dtype_r8,(/pcols,pverp/),sh_flxprc_idx) + call pbuf_add_field('SH_FLXPRC','physpkg',dtype_r8,(/pcols,pverp/),sh_flxprc_idx) ! shallow interface gbm flux_convective_cloud_snow (kg/m2/s) - call pbuf_add_field('SH_FLXSNW','physpkg',dtype_r8,(/pcols,pverp/),sh_flxsnw_idx) + call pbuf_add_field('SH_FLXSNW','physpkg',dtype_r8,(/pcols,pverp/),sh_flxsnw_idx) ! shallow gbm cloud liquid water (kg/kg) - call pbuf_add_field('SH_CLDLIQ','physpkg',dtype_r8,(/pcols,pver/),sh_cldliq_idx) + call pbuf_add_field('SH_CLDLIQ','physpkg',dtype_r8,(/pcols,pver/),sh_cldliq_idx) ! shallow gbm cloud ice water (kg/kg) - call pbuf_add_field('SH_CLDICE','physpkg',dtype_r8,(/pcols,pver/),sh_cldice_idx) + call pbuf_add_field('SH_CLDICE','physpkg',dtype_r8,(/pcols,pver/),sh_cldice_idx) ! If gravity waves from shallow convection are on, output this field. if (use_gw_convect_sh) then @@ -154,7 +155,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) use spmd_utils, only : masterproc use cam_abortutils, only : endrun use phys_control, only : cam_physpkg_is - + use physics_buffer, only : pbuf_get_index, physics_buffer_desc, pbuf_set_field real(r8), intent(in) :: pref_edge(plevp) ! Reference pressures at interfaces @@ -163,7 +164,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) integer limcnv ! Top interface level limit for convection integer k character(len=16) :: eddy_scheme - + ! SPCAM does its own convection if (shallow_scheme == 'SPCAM') return @@ -221,7 +222,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) call addfld( 'PCLDBOT', horiz_only, 'A', '1', 'Pressure of cloud base' ) call addfld( 'FREQSH', horiz_only, 'A', 'fraction', 'Fractional occurance of shallow convection' ) - + call addfld( 'HKFLXPRC', (/ 'ilev' /), 'A', 'kg/m2/s', 'Flux of precipitation from HK convection' ) call addfld( 'HKFLXSNW', (/ 'ilev' /), 'A', 'kg/m2/s', 'Flux of snow from HK convection' ) call addfld( 'HKNTPRPD', (/ 'lev' /), 'A', 'kg/kg/s', 'Net precipitation production from HK convection' ) @@ -286,7 +287,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) if( masterproc ) then write(iulog,*) 'MFINTI: Convection will be capped at intfc ', limcnv, ' which is ', pref_edge(limcnv), ' pascals' end if - + call mfinti( rair, cpair, gravit, latvap, rhoh2o, limcnv) ! Get args from inti.F90 case('UW') ! Park and Bretherton shallow convection scheme @@ -346,7 +347,7 @@ end function convect_shallow_use_shfrc !=============================================================================== ! subroutine convect_shallow_tend( ztodt , cmfmc , & - qc , qc2 , rliq , rliq2 , & + qc , qc2 , rliq , rliq2 , & state , ptend_all, pbuf, cam_in) use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_set_field, pbuf_old_tim_idx @@ -357,7 +358,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & use physics_types, only : physics_ptend_dealloc use physics_types, only : physics_ptend_sum use camsrfexch, only : cam_in_t - + use constituents, only : pcnst, cnst_get_ind, cnst_get_type_byind use hk_conv, only : cmfmca use uwshcu, only : compute_uwshcu_inv @@ -365,7 +366,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & use time_manager, only : get_nstep use wv_saturation, only : qsat - use physconst, only : latice, latvap, rhoh2o + use physconst, only : latice, latvap, rhoh2o, tmelt, gravit use spmd_utils, only : iam implicit none @@ -381,7 +382,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & real(r8), intent(out) :: rliq2(pcols) ! Vertically-integrated reserved cloud condensate [ m/s ] real(r8), intent(out) :: qc2(pcols,pver) ! Same as qc but only from shallow convection scheme - + real(r8), intent(inout) :: cmfmc(pcols,pverp) ! Moist deep + shallow convection cloud mass flux [ kg/s/m2 ] real(r8), intent(inout) :: qc(pcols,pver) ! dq/dt due to export of cloud water into environment by shallow @@ -392,7 +393,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! --------------- ! - ! Local Variables ! + ! Local Variables ! ! --------------- ! integer :: i, k, m integer :: n, x @@ -432,7 +433,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & real(r8) :: pcnb(pcols) ! Bottom pressure level of shallow + deep convective activity real(r8) :: cmfsl(pcols,pverp ) ! Convective flux of liquid water static energy real(r8) :: cmflq(pcols,pverp ) ! Convective flux of total water in energy unit - + real(r8) :: ftem_preCu(pcols,pver) ! Saturation vapor pressure after shallow Cu convection real(r8) :: tem2(pcols,pver) ! Saturation specific humidity and RH real(r8) :: t_preCu(pcols,pver) ! Temperature after shallow Cu convection @@ -442,7 +443,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & real(r8) :: icwmr_UW(pcols,pver) ! In-cloud Cumulus LWC [ kg/m2 ] real(r8) :: icimr_UW(pcols,pver) ! In-cloud Cumulus IWC [ kg/m2 ] real(r8) :: ptend_tracer(pcols,pver,pcnst) ! Tendencies of tracers - real(r8) :: sum1, sum2, sum3, pdelx + real(r8) :: sum1, sum2, sum3, pdelx real(r8) :: landfracdum(pcols) real(r8), dimension(pcols,pver) :: sl, qt, slv @@ -476,14 +477,14 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & type(unicon_out_t) :: unicon_out ! ----------------------- ! - ! Main Computation Begins ! + ! Main Computation Begins ! ! ----------------------- ! zero = 0._r8 nstep = get_nstep() lchnk = state%lchnk ncol = state%ncol - + call physics_state_copy( state, state1 ) ! Copy state to local state1. ! Associate pointers with physics buffer fields @@ -553,7 +554,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & snow = 0._r8 case('Hack') ! Hack scheme - + lq(:) = .TRUE. call physics_ptend_init( ptend_loc, state%psetcols, 'cmfmca', ls=.true., lq=lq ) ! Initialize local ptend type @@ -565,7 +566,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & state%rpdel , state%zm , tpert , qpert , state%phis , & pblh , state%t , state%q , ptend_loc%s , ptend_loc%q , & cmfmc2 , rprdsh , cmfsl , cmflq , precc , & - qc2 , cnt2 , cnb2 , icwmr , rliq2 , & + qc2 , cnt2 , cnb2 , icwmr , rliq2 , & state%pmiddry, state%pdeldry, state%rpdeldry ) case('UW') ! UW shallow convection scheme @@ -576,7 +577,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! Initialize local ptend type lq(:) = .TRUE. - call physics_ptend_init( ptend_loc, state%psetcols, 'UWSHCU', ls=.true., lu=.true., lv=.true., lq=lq ) + call physics_ptend_init( ptend_loc, state%psetcols, 'UWSHCU', ls=.true., lu=.true., lv=.true., lq=lq ) call pbuf_get_field(pbuf, cush_idx, cush ,(/1,itim_old/), (/pcols,1/)) call pbuf_get_field(pbuf, tke_idx, tke) @@ -587,7 +588,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call pbuf_get_field(pbuf, sh_e_ed_ratio_idx, sh_e_ed_ratio) call compute_uwshcu_inv( pcols , pver , ncol , pcnst , ztodt , & - state%pint, state%zi, state%pmid , state%zm , state%pdel , & + state%pint, state%zi, state%pmid , state%zm , state%pdel , & state%u , state%v , state%q(:,:,1) , state%q(:,:,ixcldliq), state%q(:,:,ixcldice), & state%t , state%s , state%q(:,:,:) , & tke , cld , concld , pblh , cush , & @@ -606,14 +607,14 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! In addition, define 'icwmr' which includes both liquid and ice. ! ! --------------------------------------------------------------------- ! - icwmr(:ncol,:) = iccmr_UW(:ncol,:) + icwmr(:ncol,:) = iccmr_UW(:ncol,:) rprdsh(:ncol,:) = rprdsh(:ncol,:) + cmfdqs(:ncol,:) do m = 4, pcnst ptend_loc%q(:ncol,:pver,m) = ptend_tracer(:ncol,:pver,m) enddo ! Conservation check - + ! do i = 1, ncol ! do m = 1, pcnst ! sum1 = 0._r8 @@ -626,8 +627,8 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! pdelx = state%pdeldry(i,k) ! endif ! sum1 = sum1 + state%q(i,k,m)*pdelx - ! sum2 = sum2 +(state%q(i,k,m)+ptend_loc%q(i,k,m)*ztodt)*pdelx - ! sum3 = sum3 + ptend_loc%q(i,k,m)*pdelx + ! sum2 = sum2 +(state%q(i,k,m)+ptend_loc%q(i,k,m)*ztodt)*pdelx + ! sum3 = sum3 + ptend_loc%q(i,k,m)*pdelx ! enddo ! if( m .gt. 3 .and. abs(sum1) .gt. 1.e-13_r8 .and. abs(sum2-sum1)/sum1 .gt. 1.e-12_r8 ) then !! if( m .gt. 3 .and. abs(sum3) .gt. 1.e-13_r8 ) then @@ -671,7 +672,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & end select - ! --------------------------------------------------------! + ! --------------------------------------------------------! ! Calculate fractional occurance of shallow convection ! ! --------------------------------------------------------! @@ -696,7 +697,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! -------------------------------------------------------------- ! ! 'cnt2' & 'cnb2' are from shallow, 'cnt' & 'cnb' are from deep ! - ! 'cnt2' & 'cnb2' are the interface indices of cloud top & base: ! + ! 'cnt2' & 'cnb2' are the interface indices of cloud top & base: ! ! cnt2 = float(kpen) ! ! cnb2 = float(krel - 1) ! ! Note that indices decreases with height. ! @@ -707,28 +708,28 @@ subroutine convect_shallow_tend( 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 - + ! ----------------------------------------------- ! ! This quantity was previously known as CMFDQR. ! ! Now CMFDQR is the shallow rain production only. ! ! ----------------------------------------------- ! - + call pbuf_set_field(pbuf, rprdtot_idx, rprdsh(:ncol,:pver) + rprddp(:ncol,:pver), start=(/1,1/), kount=(/ncol,pver/)) - - ! ----------------------------------------------------------------------- ! + + ! ----------------------------------------------------------------------- ! ! Add shallow reserved cloud condensate to deep reserved cloud condensate ! ! qc [ kg/kg/s] , rliq [ m/s ] ! ! ----------------------------------------------------------------------- ! qc(:ncol,:pver) = qc(:ncol,:pver) + qc2(:ncol,:pver) - rliq(:ncol) = rliq(:ncol) + rliq2(:ncol) + rliq(:ncol) = rliq(:ncol) + rliq2(:ncol) ! ---------------------------------------------------------------------------- ! ! Output new partition of cloud condensate variables, as well as precipitation ! - ! ---------------------------------------------------------------------------- ! + ! ---------------------------------------------------------------------------- ! if( microp_scheme == 'MG' ) then call cnst_get_ind( 'NUMLIQ', ixnumliq ) @@ -752,12 +753,12 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 'CLDTOP' , cnt , pcols , lchnk ) call outfld( 'CLDBOT' , cnb , pcols , lchnk ) call outfld( 'PCLDTOP', pcnt , pcols , lchnk ) - call outfld( 'PCLDBOT', pcnb , pcols , lchnk ) + call outfld( 'PCLDBOT', pcnb , pcols , lchnk ) call outfld( 'FREQSH' , freqsh , pcols , lchnk ) if( shallow_scheme .eq. 'UW' ) then call outfld( 'CBMF' , cbmf , pcols , lchnk ) - call outfld( 'UWFLXPRC', flxprec , pcols , lchnk ) + call outfld( 'UWFLXPRC', flxprec , pcols , lchnk ) call outfld( 'UWFLXSNW' , flxsnow , pcols , lchnk ) endif @@ -795,8 +796,8 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 't_pre_Cu ', state1%t , pcols, lchnk ) call outfld( 'rh_pre_Cu ', ftem_preCu , pcols, lchnk ) - ! ----------------------------------------------- ! - ! Update physics state type state1 with ptend_loc ! + ! ----------------------------------------------- ! + ! Update physics state type state1 with ptend_loc ! ! ----------------------------------------------- ! call physics_update( state1, ptend_loc, ztodt ) @@ -827,8 +828,8 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 't_aft_Cu ', state1%t , pcols, lchnk ) call outfld( 'rh_aft_Cu ', ftem , pcols, lchnk ) - tten(:ncol,:) = ( state1%t(:ncol,:pver) - t_preCu(:ncol,:) ) / ztodt - rhten(:ncol,:) = ( ftem(:ncol,:) - ftem_preCu(:ncol,:) ) / ztodt + tten(:ncol,:) = ( state1%t(:ncol,:pver) - t_preCu(:ncol,:) ) / ztodt + rhten(:ncol,:) = ( ftem(:ncol,:) - ftem_preCu(:ncol,:) ) / ztodt call outfld( 'tten_Cu ', tten , pcols, lchnk ) call outfld( 'rhten_Cu ', rhten , pcols, lchnk ) @@ -837,7 +838,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! ------------------------------------------------------------------------ ! ! UW-Shallow Cumulus scheme includes ! ! evaporation physics inside in it. So when 'shallow_scheme = UW', we must ! - ! NOT perform below 'zm_conv_evap'. ! + ! NOT perform below 'zm_conv_evap_run'. ! ! ------------------------------------------------------------------------ ! if( shallow_scheme .eq. 'Hack' ) then @@ -855,7 +856,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & lq(1) = .TRUE. lq(2:) = .FALSE. - call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_evap', ls=.true., lq=lq) + call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_evap_run', ls=.true., lq=lq) call pbuf_get_field(pbuf, sh_flxprc_idx, flxprec ) call pbuf_get_field(pbuf, sh_flxsnw_idx, flxsnow ) @@ -866,17 +867,24 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & sh_cldliq(:ncol,:) = 0._r8 sh_cldice(:ncol,:) = 0._r8 - call zm_conv_evap( state1%ncol, state1%lchnk, & - state1%t, state1%pmid, state1%pdel, state1%q(:pcols,:pver,1), & - landfracdum, & - ptend_loc%s, tend_s_snwprd, tend_s_snwevmlt, & - ptend_loc%q(:pcols,:pver,1), & - rprdsh, cld, ztodt, & - precc, snow, ntprprd, ntsnprd , flxprec, flxsnow ) - - ! ------------------------------------------ ! - ! record history variables from zm_conv_evap ! - ! ------------------------------------------ ! + !REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + tend_s_snwprd(:,:) = 0._r8 + tend_s_snwevmlt(:,:) = 0._r8 + snow(:) = 0._r8 + !REMOVECAM_END + + call zm_conv_evap_run(state1%ncol, pver, pverp, & + gravit, latice, latvap, tmelt, & + cpair, zmconv_ke, zmconv_ke_lnd, zmconv_org, & + state1%t(:ncol,:),state1%pmid(:ncol,:),state1%pdel(:ncol,:),state1%q(:ncol,:pver,1), & + landfracdum(:ncol), & + ptend_loc%s(:ncol,:), tend_s_snwprd(:ncol,:), tend_s_snwevmlt(:ncol,:), ptend_loc%q(:ncol,:pver,1), & + rprdsh(:ncol,:), cld(:ncol,:), ztodt, & + precc(:ncol), snow(:ncol), ntprprd(:ncol,:), ntsnprd(:ncol,:), flxprec(:ncol,:), flxsnow(:ncol,:) ) + + ! ---------------------------------------------- ! + ! record history variables from zm_conv_evap_run ! + ! ---------------------------------------------- ! evapcsh(:ncol,:pver) = ptend_loc%q(:ncol,:pver,1) @@ -894,7 +902,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 'HKNTSNPD' , ntsnprd , pcols, lchnk ) call outfld( 'HKEIHEAT' , ptend_loc%s , pcols, lchnk ) - ! ---------------------------------------------------------------- ! + ! ---------------------------------------------------------------- ! ! Add tendency from this process to tend from other processes here ! ! ---------------------------------------------------------------- ! diff --git a/src/physics/cam/macrop_driver.F90 b/src/physics/cam/macrop_driver.F90 index 3e7c276b3c..92d52fff8c 100644 --- a/src/physics/cam/macrop_driver.F90 +++ b/src/physics/cam/macrop_driver.F90 @@ -6,7 +6,7 @@ module macrop_driver ! Provides the CAM interface to the prognostic cloud macrophysics ! ! Author: Andrew Gettelman, Cheryl Craig October 2010 - ! Origin: modified from stratiform.F90 elements + ! Origin: modified from stratiform.F90 elements ! (Boville 2002, Coleman 2004, Park 2009, Kay 2010) !------------------------------------------------------------------------------------------------------- @@ -22,7 +22,6 @@ module macrop_driver use perf_mod, only: t_startf, t_stopf use cam_logfile, only: iulog use cam_abortutils, only: endrun - use zm_conv_intr, only: zmconv_microp implicit none private @@ -42,12 +41,12 @@ module macrop_driver ! Private Module Parameters ! ! ------------------------- ! - ! 'cu_det_st' : If .true. (.false.), detrain cumulus liquid condensate into the pre-existing liquid stratus - ! (environment) without (with) macrophysical evaporation. If there is no pre-esisting stratus, + ! 'cu_det_st' : If .true. (.false.), detrain cumulus liquid condensate into the pre-existing liquid stratus + ! (environment) without (with) macrophysical evaporation. If there is no pre-esisting stratus, ! evaporate cumulus liquid condensate. This option only influences the treatment of cumulus ! liquid condensate, not cumulus ice condensate. - logical, parameter :: cu_det_st = .false. + logical, parameter :: cu_det_st = .false. ! Parameters used for selecting generalized critical RH for liquid and ice stratus integer :: rhminl_opt = 0 @@ -79,11 +78,11 @@ module macrop_driver ast_idx, &! stratiform cloud fraction index in physics buffer aist_idx, &! ice stratiform cloud fraction index in physics buffer alst_idx, &! liquid stratiform cloud fraction index in physics buffer - qist_idx, &! ice stratiform in-cloud IWC - qlst_idx, &! liquid stratiform in-cloud LWC + qist_idx, &! ice stratiform in-cloud IWC + qlst_idx, &! liquid stratiform in-cloud LWC concld_idx, &! concld index in physics buffer - fice_idx, & - cmeliq_idx, & + fice_idx, & + cmeliq_idx, & shfrc_idx integer :: & @@ -98,8 +97,8 @@ module macrop_driver qtl_flx_idx = -1, &! overbar(w'qtl' where qtl = qv + ql) from the PBL scheme qti_flx_idx = -1, &! overbar(w'qti' where qti = qv + qi) from the PBL scheme cmfr_det_idx = -1, &! detrained convective mass flux from UNICON - qlr_det_idx = -1, &! detrained convective ql from UNICON - qir_det_idx = -1, &! detrained convective qi from UNICON + qlr_det_idx = -1, &! detrained convective ql from UNICON + qir_det_idx = -1, &! detrained convective qi from UNICON cmfmc_sh_idx = -1 contains @@ -166,7 +165,7 @@ subroutine macrop_driver_register ! ! !---------------------------------------------------------------------- ! - + use physics_buffer, only : pbuf_add_field, dtype_r8, dyn_time_lvls !----------------------------------------------------------------------- @@ -203,12 +202,12 @@ subroutine macrop_driver_init(pbuf2d) !-------------------------------------------- ! ! ! ! Initialize the cloud water parameterization ! - ! ! + ! ! !-------------------------------------------- ! use physics_buffer, only : pbuf_get_index use cam_history, only: addfld, add_default use convect_shallow, only: convect_shallow_use_shfrc - + type(physics_buffer_desc), pointer :: pbuf2d(:,:) logical :: history_aerosol ! Output the MAM aerosol tendencies @@ -234,7 +233,7 @@ subroutine macrop_driver_init(pbuf2d) if( convect_shallow_use_shfrc() ) then use_shfrc = .true. shfrc_idx = pbuf_get_index('shfrc') - else + else use_shfrc = .false. endif @@ -269,7 +268,7 @@ subroutine macrop_driver_init(pbuf2d) call addfld ('CLDST', (/ 'lev' /), 'A', 'fraction', 'Stratus cloud fraction' ) call addfld ('CONCLD', (/ 'lev' /), 'A', 'fraction', 'Convective cloud cover' ) - + call addfld ('CLR_LIQ', (/ 'lev' /), 'A', 'fraction', 'Clear sky fraction for liquid stratus' ) call addfld ('CLR_ICE', (/ 'lev' /), 'A', 'fraction', 'Clear sky fraction for ice stratus' ) @@ -299,7 +298,7 @@ subroutine macrop_driver_init(pbuf2d) call add_default ('MACPDQ ', history_budget_histfile_num, ' ') call add_default ('MACPDLIQ ', history_budget_histfile_num, ' ') call add_default ('MACPDICE ', history_budget_histfile_num, ' ') - + call add_default ('CLDVAPADJ', history_budget_histfile_num, ' ') call add_default ('CLDLIQLIM', history_budget_histfile_num, ' ') call add_default ('CLDLIQDET', history_budget_histfile_num, ' ') @@ -328,14 +327,6 @@ subroutine macrop_driver_init(pbuf2d) CC_qlst_idx = pbuf_get_index('CC_qlst') cmfmc_sh_idx = pbuf_get_index('CMFMC_SH') - if (zmconv_microp) then - dlfzm_idx = pbuf_get_index('DLFZM') - difzm_idx = pbuf_get_index('DIFZM') - dnlfzm_idx = pbuf_get_index('DNLFZM') - dnifzm_idx = pbuf_get_index('DNIFZM') - end if - - if (rhminl_opt > 0 .or. rhmini_opt > 0) then cmfr_det_idx = pbuf_get_index('cmfr_det', istat) if (istat < 0) call endrun(subname//': macrop option requires cmfr_det in pbuf') @@ -361,7 +352,7 @@ subroutine macrop_driver_init(pbuf2d) end if end if - ! Init pbuf fields. Note that the fields CLD, CONCLD, QCWAT, LCWAT, + ! Init pbuf fields. Note that the fields CLD, CONCLD, QCWAT, LCWAT, ! ICCWAT, and TCWAT are initialized in phys_inidat. if (is_first_step()) then call pbuf_set_field(pbuf2d, ast_idx, 0._r8) @@ -392,13 +383,13 @@ subroutine macrop_driver_tend( & pbuf, & det_s, det_ice) - !-------------------------------------------------------- ! - ! ! + !-------------------------------------------------------- ! + ! ! ! Purpose: ! ! ! ! Interface to detrain, cloud fraction and ! ! cloud macrophysics subroutines ! - ! ! + ! ! ! Author: A. Gettelman, C. Craig, Oct 2010 ! ! based on stratiform_tend by D.B. Coleman 4/2010 ! ! ! @@ -438,7 +429,7 @@ subroutine macrop_driver_tend( & real(r8), intent(in) :: zdu(pcols,pver) ! Detrainment rate from deep convection - ! These two variables are needed for energy check + ! These two variables are needed for energy check real(r8), intent(out) :: det_s(pcols) ! Integral of detrained static energy from ice real(r8), intent(out) :: det_ice(pcols) ! Integral of detrained ice for energy check @@ -525,13 +516,13 @@ subroutine macrop_driver_tend( & real(r8) ltend(pcols,pver) ! Cloud liquid water tendencies real(r8) fice(pcols,pver) ! Fractional ice content within cloud real(r8) fsnow(pcols,pver) ! Fractional snow production - real(r8) homoo(pcols,pver) - real(r8) qcreso(pcols,pver) - real(r8) prcio(pcols,pver) - real(r8) praio(pcols,pver) + real(r8) homoo(pcols,pver) + real(r8) qcreso(pcols,pver) + real(r8) prcio(pcols,pver) + real(r8) praio(pcols,pver) real(r8) qireso(pcols,pver) real(r8) ftem(pcols,pver) - real(r8) pracso (pcols,pver) + real(r8) pracso (pcols,pver) real(r8) dpdlfliq(pcols,pver) real(r8) dpdlfice(pcols,pver) real(r8) shdlfliq(pcols,pver) @@ -575,11 +566,11 @@ subroutine macrop_driver_tend( & real(r8) qi_inout(pcols,pver) real(r8) concld_old(pcols,pver) - ! Note that below 'clr_old' is defined using 'alst_old' not 'ast_old' for full consistency with the - ! liquid condensation process which is using 'alst' not 'ast'. + ! Note that below 'clr_old' is defined using 'alst_old' not 'ast_old' for full consistency with the + ! liquid condensation process which is using 'alst' not 'ast'. ! For microconsistency use 'concld_old', since 'alst_old' was computed using 'concld_old'. ! Since convective updraft fractional area is small, it does not matter whether 'concld' or 'concld_old' is used. - ! Note also that 'clri_old' is defined using 'ast_old' since current microphysics is operating on 'ast_old' + ! Note also that 'clri_old' is defined using 'ast_old' since current microphysics is operating on 'ast_old' real(r8) clrw_old(pcols,pver) ! (1 - concld_old - alst_old) real(r8) clri_old(pcols,pver) ! (1 - concld_old - ast_old) @@ -669,7 +660,7 @@ subroutine macrop_driver_tend( & dlf_ni(:,:) = 0._r8 ! ------------------------------------- ! - ! From here, process computation begins ! + ! From here, process computation begins ! ! ------------------------------------- ! ! ----------------------------------------------------------------------------- ! @@ -689,23 +680,16 @@ subroutine macrop_driver_tend( & ! If convection scheme can handle this internally, this step is not necssary. ! (2) Assuming a certain effective droplet radius, computes number concentration ! of detrained convective cloud liquid and ice. - ! (3) If 'cu_det_st = .true' ('false'), detrain convective cloud 'liquid' into + ! (3) If 'cu_det_st = .true' ('false'), detrain convective cloud 'liquid' into ! the pre-existing 'liquid' stratus ( mean environment ). The former does ! not involve any macrophysical evaporation while the latter does. This is - ! a kind of 'targetted' deposition. Then, force in-stratus LWC to be bounded + ! a kind of 'targetted' deposition. Then, force in-stratus LWC to be bounded ! by qcst_min and qcst_max in mmacro_pcond. - ! (4) In contrast to liquid, convective ice is detrained into the environment + ! (4) In contrast to liquid, convective ice is detrained into the environment ! and involved in the sublimation. Similar bounds as liquid stratus are imposed. ! This is the key procesure generating upper-level cirrus clouds. ! The unit of dlf : [ kg/kg/s ] - if (zmconv_microp) then - call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) - call pbuf_get_field(pbuf, difzm_idx, difzm) - call pbuf_get_field(pbuf, dnlfzm_idx, dnlfzm) - call pbuf_get_field(pbuf, dnifzm_idx, dnifzm) - end if - det_s(:) = 0._r8 det_ice(:) = 0._r8 @@ -729,57 +713,43 @@ subroutine macrop_driver_tend( & ! If detrainment was done elsewhere, still update the variables used for output ! assuming that the temperature split between liquid and ice is the same as assumed ! here. - if (zmconv_microp) then - ptend_loc%q(i,k,ixcldliq) = dlfzm(i,k) + dlf2(i,k) * ( 1._r8 - dum1 ) - ptend_loc%q(i,k,ixcldice) = difzm(i,k) + dlf2(i,k) * dum1 - - ptend_loc%q(i,k,ixnumliq) = dnlfzm(i,k) + 3._r8 * ( dlf2(i,k) * ( 1._r8 - dum1 ) ) & - / (4._r8*3.14_r8*10.e-6_r8**3*997._r8) ! Shallow Convection - ptend_loc%q(i,k,ixnumice) = dnifzm(i,k) + 3._r8 * ( dlf2(i,k) * dum1 ) & - / (4._r8*3.14_r8*50.e-6_r8**3*500._r8) ! Shallow Convection - ptend_loc%s(i,k) = dlf2(i,k) * dum1 * latice - - else - if (do_detrain) then + if (do_detrain) then ptend_loc%q(i,k,ixcldliq) = dlf(i,k) * ( 1._r8 - dum1 ) ptend_loc%q(i,k,ixcldice) = dlf(i,k) * dum1 ! dum2 = dlf(i,k) * ( 1._r8 - dum1 ) ptend_loc%q(i,k,ixnumliq) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * ( 1._r8 - dum1 ) ) / & (4._r8*3.14_r8* 8.e-6_r8**3*997._r8) + & ! Deep Convection 3._r8 * ( dlf2(i,k) * ( 1._r8 - dum1 ) ) / & - (4._r8*3.14_r8*10.e-6_r8**3*997._r8) ! Shallow Convection + (4._r8*3.14_r8*10.e-6_r8**3*997._r8) ! Shallow Convection ! dum2 = dlf(i,k) * dum1 ptend_loc%q(i,k,ixnumice) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * dum1 ) / & (4._r8*3.14_r8*25.e-6_r8**3*500._r8) + & ! Deep Convection 3._r8 * ( dlf2(i,k) * dum1 ) / & (4._r8*3.14_r8*50.e-6_r8**3*500._r8) ! Shallow Convection ptend_loc%s(i,k) = dlf(i,k) * dum1 * latice - else + else ptend_loc%q(i,k,ixcldliq) = 0._r8 ptend_loc%q(i,k,ixcldice) = 0._r8 ptend_loc%q(i,k,ixnumliq) = 0._r8 ptend_loc%q(i,k,ixnumice) = 0._r8 ptend_loc%s(i,k) = 0._r8 - end if - - end if ! Only rliq is saved from deep convection, which is the reserved liquid. We need to keep ! track of the integrals of ice and static energy that is effected from conversion to ice ! so that the energy checker doesn't complain. det_s(i) = det_s(i) + ptend_loc%s(i,k)*state_loc%pdel(i,k)/gravit - det_ice(i) = det_ice(i) - ptend_loc%q(i,k,ixcldice)*state_loc%pdel(i,k)/gravit + det_ice(i) = det_ice(i) - ptend_loc%q(i,k,ixcldice)*state_loc%pdel(i,k)/gravit ! Targetted detrainment of convective liquid water either directly into the - ! existing liquid stratus or into the environment. + ! existing liquid stratus or into the environment. if( cu_det_st ) then dlf_T(i,k) = ptend_loc%s(i,k)/cpair dlf_qv(i,k) = 0._r8 dlf_ql(i,k) = ptend_loc%q(i,k,ixcldliq) dlf_qi(i,k) = ptend_loc%q(i,k,ixcldice) dlf_nl(i,k) = ptend_loc%q(i,k,ixnumliq) - dlf_ni(i,k) = ptend_loc%q(i,k,ixnumice) + dlf_ni(i,k) = ptend_loc%q(i,k,ixnumice) ptend_loc%q(i,k,ixcldliq) = 0._r8 ptend_loc%q(i,k,ixcldice) = 0._r8 ptend_loc%q(i,k,ixnumliq) = 0._r8 @@ -792,15 +762,9 @@ subroutine macrop_driver_tend( & dpdlft (i,k) = 0._r8 shdlft (i,k) = 0._r8 else - if (zmconv_microp) then - dpdlfliq(i,k) = dlfzm(i,k) - dpdlfice(i,k) = difzm(i,k) - dpdlft (i,k) = 0._r8 - else - dpdlfliq(i,k) = ( dlf(i,k) - dlf2(i,k) ) * ( 1._r8 - dum1 ) - dpdlfice(i,k) = ( dlf(i,k) - dlf2(i,k) ) * ( dum1 ) - dpdlft (i,k) = ( dlf(i,k) - dlf2(i,k) ) * dum1 * latice/cpair - end if + dpdlfliq(i,k) = ( dlf(i,k) - dlf2(i,k) ) * ( 1._r8 - dum1 ) + dpdlfice(i,k) = ( dlf(i,k) - dlf2(i,k) ) * ( dum1 ) + dpdlft (i,k) = ( dlf(i,k) - dlf2(i,k) ) * dum1 * latice/cpair shdlfliq(i,k) = dlf2(i,k) * ( 1._r8 - dum1 ) shdlfice(i,k) = dlf2(i,k) * ( dum1 ) @@ -833,7 +797,7 @@ subroutine macrop_driver_tend( & ! -------------------------------------- ! ! ----------------------------------------------------------------------------- ! - ! Treatment of cloud fraction in CAM4 and CAM5 differs ! + ! Treatment of cloud fraction in CAM4 and CAM5 differs ! ! (1) CAM4 ! ! . Cumulus AMT = Deep Cumulus AMT ( empirical fcn of mass flux ) + ! ! Shallow Cumulus AMT ( empirical fcn of mass flux ) ! @@ -846,7 +810,7 @@ subroutine macrop_driver_tend( & ! . Stratus AMT = fcn of environmental-mean RH ( no Stability Stratus ) ! ! . Cumulus and Stratus are non-overlapped with higher priority on Cumulus ! ! . Cumulus ( both Deep and Shallow ) has its own LWC and IWC. ! - ! ----------------------------------------------------------------------------- ! + ! ----------------------------------------------------------------------------- ! concld_old(:ncol,top_lev:pver) = concld(:ncol,top_lev:pver) @@ -862,22 +826,22 @@ subroutine macrop_driver_tend( & clri_old(:ncol,:top_lev-1) = 0._r8 do k = top_lev, pver do i = 1, ncol - clrw_old(i,k) = max( 0._r8, min( 1._r8, 1._r8 - concld(i,k) - alst(i,k) ) ) - clri_old(i,k) = max( 0._r8, min( 1._r8, 1._r8 - concld(i,k) - ast(i,k) ) ) + clrw_old(i,k) = max( 0._r8, min( 1._r8, 1._r8 - concld(i,k) - alst(i,k) ) ) + clri_old(i,k) = max( 0._r8, min( 1._r8, 1._r8 - concld(i,k) - ast(i,k) ) ) end do end do if( use_shfrc ) then call pbuf_get_field(pbuf, shfrc_idx, shfrc ) - else + else allocate(shfrc(pcols,pver)) shfrc(:,:) = 0._r8 endif - ! CAM5 only uses 'concld' output from the below subroutine. + ! CAM5 only uses 'concld' output from the below subroutine. ! Stratus ('ast' = max(alst,aist)) and total cloud fraction ('cld = ast + concld') - ! will be computed using this updated 'concld' in the stratiform macrophysics - ! scheme (mmacro_pcond) later below. + ! will be computed using this updated 'concld' in the stratiform macrophysics + ! scheme (mmacro_pcond) later below. call t_startf("cldfrc") @@ -901,10 +865,14 @@ subroutine macrop_driver_tend( & rdtime = 1._r8/dtime ! Define fractional amount of stratus condensate and precipitation in ice phase. - ! This uses a ramp ( -30 ~ -10 for fice, -5 ~ 0 for fsnow ). + ! This uses a ramp ( -30 ~ -10 for fice, -5 ~ 0 for fsnow ). ! The ramp within convective cloud may be different - call cldfrc_fice( ncol, state_loc%t, fice, fsnow ) +!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + fice(:,:) = 0._r8 + fsnow(:,:) = 0._r8 +!REMOVECAM_END + call cldfrc_fice( ncol, state_loc%t(:ncol,:), fice(:ncol,:), fsnow(:ncol,:) ) lq(:) = .FALSE. @@ -918,7 +886,7 @@ subroutine macrop_driver_tend( & ! Initialize local physics_ptend object again call physics_ptend_init(ptend_loc, state%psetcols, 'macro_park', & - ls=.true., lq=lq ) + ls=.true., lq=lq ) ! --------------------------------- ! ! Liquid Macrop_Driver Macrophysics ! @@ -932,9 +900,9 @@ subroutine macrop_driver_tend( & nc(:ncol,top_lev:pver) = state_loc%q(:ncol,top_lev:pver,ixnumliq) ni(:ncol,top_lev:pver) = state_loc%q(:ncol,top_lev:pver,ixnumice) - ! In CAM5, 'microphysical forcing' ( CC_... ) and 'the other advective forcings' ( ttend, ... ) + ! In CAM5, 'microphysical forcing' ( CC_... ) and 'the other advective forcings' ( ttend, ... ) ! are separately provided into the prognostic microp_driver macrophysics scheme. This is an - ! attempt to resolve in-cloud and out-cloud forcings. + ! attempt to resolve in-cloud and out-cloud forcings. if( get_nstep() .le. 1 ) then tcwat(:ncol,top_lev:pver) = state_loc%t(:ncol,top_lev:pver) @@ -958,7 +926,7 @@ subroutine macrop_driver_tend( & CC_qlst(:ncol,:) = 0._r8 else ttend(:ncol,top_lev:pver) = ( state_loc%t(:ncol,top_lev:pver) - tcwat(:ncol,top_lev:pver)) * rdtime & - - CC_T(:ncol,top_lev:pver) + - CC_T(:ncol,top_lev:pver) qtend(:ncol,top_lev:pver) = ( state_loc%q(:ncol,top_lev:pver,1) - qcwat(:ncol,top_lev:pver)) * rdtime & - CC_qv(:ncol,top_lev:pver) ltend(:ncol,top_lev:pver) = ( qc(:ncol,top_lev:pver) + qi(:ncol,top_lev:pver) - lcwat(:ncol,top_lev:pver) ) * rdtime & @@ -972,7 +940,7 @@ subroutine macrop_driver_tend( & endif lmitend(:ncol,top_lev:pver) = ltend(:ncol,top_lev:pver) - itend(:ncol,top_lev:pver) - t_inout(:ncol,top_lev:pver) = tcwat(:ncol,top_lev:pver) + t_inout(:ncol,top_lev:pver) = tcwat(:ncol,top_lev:pver) qv_inout(:ncol,top_lev:pver) = qcwat(:ncol,top_lev:pver) ql_inout(:ncol,top_lev:pver) = lcwat(:ncol,top_lev:pver) - iccwat(:ncol,top_lev:pver) qi_inout(:ncol,top_lev:pver) = iccwat(:ncol,top_lev:pver) @@ -982,20 +950,20 @@ subroutine macrop_driver_tend( & ! Liquid Microp_Driver Macrophysics. ! The main roles of this subroutines are ! (1) compute net condensation rate of stratiform liquid ( cmeliq ) - ! (2) compute liquid stratus and ice stratus fractions. + ! (2) compute liquid stratus and ice stratus fractions. ! Note 'ttend...' are advective tendencies except microphysical process while - ! 'CC...' are microphysical tendencies. + ! 'CC...' are microphysical tendencies. call mmacro_pcond( lchnk, ncol, dtime, state_loc%pmid, state_loc%pdel, & - t_inout, qv_inout, ql_inout, qi_inout, nl_inout, ni_inout, & + t_inout, qv_inout, ql_inout, qi_inout, nl_inout, ni_inout, & ttend, qtend, lmitend, itend, nltend, nitend, & - CC_T, CC_qv, CC_ql, CC_qi, CC_nl, CC_ni, CC_qlst, & + CC_T, CC_qv, CC_ql, CC_qi, CC_nl, CC_ni, CC_qlst, & dlf_T, dlf_qv, dlf_ql, dlf_qi, dlf_nl, dlf_ni, & concld_old, concld, clrw_old, clri_old, landfrac, snowh, & tke, qtl_flx, qti_flx, cmfr_det, qlr_det, qir_det, & tlat, qvlat, qcten, qiten, ncten, niten, & cmeliq, qvadj, qladj, qiadj, qllim, qilim, & - cld, alst, aist, qlst, qist, do_cldice ) + cld, alst, aist, qlst, qist, do_cldice ) ! Copy of concld/fice to put in physics buffer ! Below are used only for convective cloud. @@ -1021,20 +989,20 @@ subroutine macrop_driver_tend( & ! Check to make sure that the macrophysics code is respecting the flags that control ! whether cldwat should be prognosing cloud ice and cloud liquid or not. - if ((.not. do_cldice) .and. (qiten(i,k) /= 0.0_r8)) then + if ((.not. do_cldice) .and. (qiten(i,k) /= 0.0_r8)) then call endrun("macrop_driver:ERROR - "// & "Cldwat is configured not to prognose cloud ice, but mmacro_pcond has ice mass tendencies.") end if - if ((.not. do_cldice) .and. (niten(i,k) /= 0.0_r8)) then + if ((.not. do_cldice) .and. (niten(i,k) /= 0.0_r8)) then call endrun("macrop_driver:ERROR -"// & " Cldwat is configured not to prognose cloud ice, but mmacro_pcond has ice number tendencies.") end if - if ((.not. do_cldliq) .and. (qcten(i,k) /= 0.0_r8)) then + if ((.not. do_cldliq) .and. (qcten(i,k) /= 0.0_r8)) then call endrun("macrop_driver:ERROR - "// & "Cldwat is configured not to prognose cloud liquid, but mmacro_pcond has liquid mass tendencies.") end if - if ((.not. do_cldliq) .and. (ncten(i,k) /= 0.0_r8)) then + if ((.not. do_cldliq) .and. (ncten(i,k) /= 0.0_r8)) then call endrun("macrop_driver:ERROR - "// & "Cldwat is configured not to prognose cloud liquid, but mmacro_pcond has liquid number tendencies.") end if @@ -1064,7 +1032,7 @@ subroutine macrop_driver_tend( & call outfld( 'ICECLDF ', aist, pcols, lchnk ) call outfld( 'LIQCLDF ', alst, pcols, lchnk ) - call outfld( 'AST', ast, pcols, lchnk ) + call outfld( 'AST', ast, pcols, lchnk ) call outfld( 'CONCLD ', concld, pcols, lchnk ) call outfld( 'CLDST ', cldst, pcols, lchnk ) @@ -1075,7 +1043,7 @@ subroutine macrop_driver_tend( & ! calculations and outfld calls for CLDLIQSTR, CLDICESTR, CLDLIQCON, CLDICECON for CFMIP ! initialize local variables - mr_ccliq = 0._r8 !! not seen by radiation, so setting to 0 + mr_ccliq = 0._r8 !! not seen by radiation, so setting to 0 mr_ccice = 0._r8 !! not seen by radiation, so setting to 0 mr_lsliq = 0._r8 mr_lsice = 0._r8 @@ -1098,7 +1066,7 @@ subroutine macrop_driver_tend( & call outfld( 'CLDICECON ', mr_ccice, pcols, lchnk ) ! ------------------------------------------------- ! - ! Save equilibrium state variables for macrophysics ! + ! Save equilibrium state variables for macrophysics ! ! at the next time step ! ! ------------------------------------------------- ! cldsice = 0._r8 @@ -1125,7 +1093,7 @@ end subroutine macrop_driver_tend ! With CLUBB, we are seeing relative humidity with respect to water ! greater than 1. This should not be happening and is not what the ! microphsyics expects from the macrophysics. As a work around while -! this issue is investigated in CLUBB, this routine will enfornce a +! this issue is investigated in CLUBB, this routine will enfornce a ! maximum RHliq of 1 everywhere in the atmosphere. Any excess water will ! be converted into cloud drops. subroutine liquid_macro_tend(npccn,t,p,qv,qc,nc,xxlv,deltat,stend,qvtend,qctend,nctend,vlen) @@ -1136,7 +1104,7 @@ subroutine liquid_macro_tend(npccn,t,p,qv,qc,nc,xxlv,deltat,stend,qvtend,qctend, use cldfrc2m, only: rhmini_const, rhmaxi_const integer, intent(in) :: vlen - real(r8), dimension(vlen), intent(in) :: npccn !Activated number of cloud condensation nuclei + real(r8), dimension(vlen), intent(in) :: npccn !Activated number of cloud condensation nuclei real(r8), dimension(vlen), intent(in) :: t !temperature (k) real(r8), dimension(vlen), intent(in) :: p !pressure (pa) real(r8), dimension(vlen), intent(in) :: qv !water vapor mixing ratio @@ -1144,18 +1112,18 @@ subroutine liquid_macro_tend(npccn,t,p,qv,qc,nc,xxlv,deltat,stend,qvtend,qctend, real(r8), dimension(vlen), intent(in) :: nc !liquid number concentration real(r8), intent(in) :: xxlv !latent heat of vaporization real(r8), intent(in) :: deltat !timestep - real(r8), dimension(vlen), intent(out) :: stend ! 'temperature' tendency + real(r8), dimension(vlen), intent(out) :: stend ! 'temperature' tendency real(r8), dimension(vlen), intent(out) :: qvtend !vapor tendency real(r8), dimension(vlen), intent(out) :: qctend !liquid mass tendency - real(r8), dimension(vlen), intent(out) :: nctend !liquid number tendency + real(r8), dimension(vlen), intent(out) :: nctend !liquid number tendency real(r8) :: ESL(vlen) real(r8) :: QSL(vlen) - real(r8) :: drop_size_param + real(r8) :: drop_size_param integer :: i drop_size_param = 3._r8/(4._r8*3.14_r8*6.e-6_r8**3*rhow) - + do i = 1, vlen stend(i) = 0._r8 qvtend(i) = 0._r8 @@ -1164,18 +1132,18 @@ subroutine liquid_macro_tend(npccn,t,p,qv,qc,nc,xxlv,deltat,stend,qvtend,qctend, end do ! calculate qsatl from t,p,q - !$acc data copyin(t,p) copyout(ESL,QSL) + !$acc data copyin(t,p) copyout(ESL,QSL) call wv_sat_qsat_water_vect(t, p, ESL, QSL, vlen) !$acc end data do i = 1, vlen ! Don't allow supersaturation with respect to liquid. if (qv(i) > QSL(i)) then - + qctend(i) = (qv(i) - QSL(i)) / deltat qvtend(i) = 0._r8 - qctend(i) stend(i) = qctend(i) * xxlv ! moist static energy tend...[J/kg/s] ! - + ! If drops exists (more than 1 L-1) and there is condensation, ! do not add to number (= growth), otherwise add 6um drops. ! diff --git a/src/physics/cam/rk_stratiform.F90 b/src/physics/cam/rk_stratiform.F90 index 5d165acc40..84607a20b7 100644 --- a/src/physics/cam/rk_stratiform.F90 +++ b/src/physics/cam/rk_stratiform.F90 @@ -2,7 +2,7 @@ module rk_stratiform !------------------------------------------------------------------------------------------------------- ! -! Provides the CAM interface to the Rasch and Kristjansson (RK) +! Provides the CAM interface to the Rasch and Kristjansson (RK) ! prognostic cloud microphysics, and the cam3/4 macrophysics. ! !------------------------------------------------------------------------------------------------------- @@ -27,26 +27,26 @@ module rk_stratiform public :: rk_stratiform_tend public :: rk_stratiform_readnl -! Physics buffer indices +! Physics buffer indices integer :: landm_idx = 0 -integer :: qcwat_idx = 0 -integer :: lcwat_idx = 0 -integer :: tcwat_idx = 0 +integer :: qcwat_idx = 0 +integer :: lcwat_idx = 0 +integer :: tcwat_idx = 0 -integer :: cld_idx = 0 -integer :: ast_idx = 0 -integer :: concld_idx = 0 -integer :: fice_idx = 0 +integer :: cld_idx = 0 +integer :: ast_idx = 0 +integer :: concld_idx = 0 +integer :: fice_idx = 0 -integer :: qme_idx = 0 -integer :: prain_idx = 0 -integer :: nevapr_idx = 0 +integer :: qme_idx = 0 +integer :: prain_idx = 0 +integer :: nevapr_idx = 0 integer :: wsedl_idx = 0 -integer :: rei_idx = 0 -integer :: rel_idx = 0 +integer :: rei_idx = 0 +integer :: rel_idx = 0 integer :: shfrc_idx = 0 integer :: cmfmc_sh_idx = 0 @@ -92,8 +92,8 @@ subroutine rk_stratiform_readnl(nlfile) character(len=*), parameter :: subname = 'rk_stratiform_readnl' ! Namelist variables - real(r8) :: rk_strat_icritw = unset_r8 ! icritw = threshold for autoconversion of warm ice - real(r8) :: rk_strat_icritc = unset_r8 ! icritc = threshold for autoconversion of cold ice + real(r8) :: rk_strat_icritw = unset_r8 ! icritw = threshold for autoconversion of warm ice + real(r8) :: rk_strat_icritc = unset_r8 ! icritc = threshold for autoconversion of cold ice real(r8) :: rk_strat_conke = unset_r8 ! conke = tunable constant for evaporation of precip real(r8) :: rk_strat_r3lcrit = unset_r8 ! r3lcrit = critical radius where liq conversion begins real(r8) :: rk_strat_polstrat_rhmin = unset_r8 ! condensation threadhold in polar stratosphere @@ -144,7 +144,7 @@ subroutine rk_stratiform_register use constituents, only: cnst_add, pcnst use physconst, only: mwh2o, cpair - + use physics_buffer, only : pbuf_add_field, dtype_r8, dyn_time_lvls !----------------------------------------------------------------------- @@ -166,7 +166,7 @@ subroutine rk_stratiform_register call pbuf_add_field('AST', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), ast_idx) call pbuf_add_field('CONCLD', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), concld_idx) - call pbuf_add_field('FICE', 'physpkg', dtype_r8, (/pcols,pver/), fice_idx) + call pbuf_add_field('FICE', 'physpkg', dtype_r8, (/pcols,pver/), fice_idx) call pbuf_add_field('QME', 'physpkg', dtype_r8, (/pcols,pver/), qme_idx) call pbuf_add_field('PRAIN', 'physpkg', dtype_r8, (/pcols,pver/), prain_idx) @@ -186,8 +186,8 @@ end subroutine rk_stratiform_register function rk_stratiform_implements_cnst(name) - !----------------------------------------------------------------------------- ! - ! ! + !----------------------------------------------------------------------------- ! + ! ! ! Return true if specified constituent is implemented by this package ! ! ! !----------------------------------------------------------------------------- ! @@ -208,7 +208,7 @@ subroutine rk_stratiform_init_cnst(name, latvals, lonvals, mask, q) !----------------------------------------------------------------------- ! ! ! ! Initialize the cloud water mixing ratios (liquid and ice), if they are ! - ! not read from the initial file ! + ! not read from the initial file ! ! ! !----------------------------------------------------------------------- ! @@ -237,7 +237,7 @@ subroutine rk_stratiform_init() !-------------------------------------------- ! ! ! ! Initialize the cloud water parameterization ! - ! ! + ! ! !-------------------------------------------- ! use physics_buffer, only: physics_buffer_desc, pbuf_get_index @@ -247,7 +247,7 @@ subroutine rk_stratiform_init() use phys_control, only: cam_physpkg_is use physconst, only: tmelt, rhodair, rh2o use cldwat, only: inimc - + integer :: m, mm logical :: history_amwg ! output the variables used by the AMWG diag package logical :: history_aerosol ! Output the MAM aerosol tendencies @@ -258,7 +258,7 @@ subroutine rk_stratiform_init() !----------------------------------------------------------------------- call phys_getopts( history_aerosol_out = history_aerosol , & - history_amwg_out = history_amwg , & + history_amwg_out = history_amwg , & history_budget_out = history_budget , & history_budget_histfile_num_out = history_budget_histfile_num) @@ -268,7 +268,7 @@ subroutine rk_stratiform_init() if( convect_shallow_use_shfrc() ) then use_shfrc = .true. shfrc_idx = pbuf_get_index('shfrc') - else + else use_shfrc = .false. endif @@ -326,7 +326,7 @@ subroutine rk_stratiform_init() call addfld ('ICWMR', (/ 'lev' /), 'A', 'kg/kg' , 'Prognostic in-cloud water mixing ratio' ) call addfld ('ICIMR', (/ 'lev' /), 'A', 'kg/kg' , 'Prognostic in-cloud ice mixing ratio' ) call addfld ('PCSNOW', horiz_only , 'A', 'm/s' , 'Snow fall from prognostic clouds' ) - + call addfld ('DQSED', (/ 'lev' /), 'A', 'kg/kg/s' , 'Water vapor tendency from cloud sedimentation' ) call addfld ('DLSED', (/ 'lev' /), 'A', 'kg/kg/s' , 'Cloud liquid tendency from sedimentation' ) call addfld ('DISED', (/ 'lev' /), 'A', 'kg/kg/s' , 'Cloud ice tendency from sedimentation' ) @@ -339,7 +339,7 @@ subroutine rk_stratiform_init() call addfld ('CNVCLD', horiz_only, 'A', 'fraction', 'Vertically integrated convective cloud amount' ) call addfld ('CLDST', (/ 'lev' /), 'A', 'fraction', 'Stratus cloud fraction' ) call addfld ('CONCLD', (/ 'lev' /), 'A', 'fraction', 'Convective cloud cover' ) - + call addfld ('AST', (/ 'lev' /), 'A','fraction' , 'Stratus cloud fraction' ) call addfld ('LIQCLDF', (/ 'lev' /), 'A', 'fraction', 'Stratus Liquid cloud fraction' ) call addfld ('ICECLDF', (/ 'lev' /), 'A', 'fraction', 'Stratus ICE cloud fraction' ) @@ -420,11 +420,11 @@ subroutine rk_stratiform_tend( & dlf2, rliq, cmfmc, ts, & sst, zdu) - !-------------------------------------------------------- ! - ! ! + !-------------------------------------------------------- ! + ! ! ! Interface to sedimentation, detrain, cloud fraction and ! ! cloud macro - microphysics subroutines ! - ! ! + ! ! !-------------------------------------------------------- ! use cloud_fraction, only: cldfrc, cldfrc_fice @@ -475,7 +475,7 @@ subroutine rk_stratiform_tend( & ! Physics buffer fields real(r8), pointer :: landm(:) ! Land fraction ramped over water - real(r8), pointer :: prec_str(:) ! [Total] Sfc flux of precip from stratiform [ m/s ] + real(r8), pointer :: prec_str(:) ! [Total] Sfc flux of precip from stratiform [ m/s ] real(r8), pointer :: snow_str(:) ! [Total] Sfc flux of snow from stratiform [ m/s ] real(r8), pointer :: prec_sed(:) ! Surface flux of total cloud water from sedimentation real(r8), pointer :: snow_sed(:) ! Surface flux of cloud ice from sedimentation @@ -517,12 +517,12 @@ subroutine rk_stratiform_tend( & real(r8) :: clc(pcols) ! Column convective cloud amount real(r8) :: relhum(pcols,pver) ! RH, output to determine drh/da real(r8) :: rhu00(pcols,pver) - real(r8) :: rhu002(pcols,pver) ! Same as rhu00 but for perturbed rh + real(r8) :: rhu002(pcols,pver) ! Same as rhu00 but for perturbed rh real(r8) :: rhdfda(pcols,pver) real(r8) :: cld2(pcols,pver) ! Same as cld but for perturbed rh - real(r8) :: concld2(pcols,pver) ! Same as concld but for perturbed rh - real(r8) :: cldst2(pcols,pver) ! Same as cldst but for perturbed rh - real(r8) :: relhum2(pcols,pver) ! RH after perturbation + real(r8) :: concld2(pcols,pver) ! Same as concld but for perturbed rh + real(r8) :: cldst2(pcols,pver) ! Same as cldst but for perturbed rh + real(r8) :: relhum2(pcols,pver) ! RH after perturbation real(r8) :: icecldf(pcols,pver) ! Ice cloud fraction real(r8) :: liqcldf(pcols,pver) ! Liquid cloud fraction (combined into cloud) real(r8) :: icecldf_out(pcols,pver) ! Ice cloud fraction @@ -547,11 +547,11 @@ subroutine rk_stratiform_tend( & real(r8) :: repartht(pcols,pver) ! Heating rate due to phase repartition of input precip real(r8) :: icimr(pcols,pver) ! In cloud ice mixing ratio real(r8) :: icwmr(pcols,pver) ! In cloud water mixing ratio - real(r8) :: fwaut(pcols,pver) - real(r8) :: fsaut(pcols,pver) - real(r8) :: fracw(pcols,pver) - real(r8) :: fsacw(pcols,pver) - real(r8) :: fsaci(pcols,pver) + real(r8) :: fwaut(pcols,pver) + real(r8) :: fsaut(pcols,pver) + real(r8) :: fracw(pcols,pver) + real(r8) :: fsacw(pcols,pver) + real(r8) :: fsaci(pcols,pver) real(r8) :: cmeice(pcols,pver) ! Rate of cond-evap of ice within the cloud real(r8) :: cmeliq(pcols,pver) ! Rate of cond-evap of liq within the cloud real(r8) :: ice2pr(pcols,pver) ! Rate of conversion of ice to precip @@ -569,8 +569,8 @@ subroutine rk_stratiform_tend( & real(r8) :: psacio(pcols,pver) ! RK accretion of cloud ice by snow (1/s) real(r8) :: iwc(pcols,pver) ! Grid box average ice water content - real(r8) :: lwc(pcols,pver) ! Grid box average liquid water content - + real(r8) :: lwc(pcols,pver) ! Grid box average liquid water content + logical :: lq(pcnst) integer :: troplev(pcols) real(r8) :: rlat(pcols) @@ -598,7 +598,7 @@ subroutine rk_stratiform_tend( & call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) call pbuf_get_field(pbuf, fice_idx, fice) - + call pbuf_get_field(pbuf, cmfmc_sh_idx, cmfmc_sh) call pbuf_get_field(pbuf, prec_str_idx, prec_str) @@ -616,7 +616,7 @@ subroutine rk_stratiform_tend( & call pbuf_get_field(pbuf, rei_idx, rei) call pbuf_get_field(pbuf, wsedl_idx, wsedl) - + ! check that qcwat and tcwat were initialized; if not then do it now. if (qcwat(1,1) == huge(1._r8)) then qcwat(:ncol,:) = state%q(:ncol,:,1) @@ -636,16 +636,16 @@ subroutine rk_stratiform_tend( & ! ------------- ! ! Allow the cloud liquid drops and ice particles to sediment. - ! This is done before adding convectively detrained cloud water, + ! This is done before adding convectively detrained cloud water, ! because the phase of the detrained water is unknown. call t_startf('stratiform_sediment') call cld_sediment_vel( ncol, & icefrac, landfrac, ocnfrac, state1%pmid, state1%pdel, state1%t, & - cld, state1%q(:,:,ixcldliq), state1%q(:,:,ixcldice), & + cld, state1%q(:,:,ixcldliq), state1%q(:,:,ixcldice), & pvliq, pvice, landm, snowh ) - + wsedl(:ncol,:pver) = pvliq(:ncol,:pver)/gravit/(state1%pmid(:ncol,:pver)/(287.15_r8*state1%t(:ncol,:pver))) lq(:) = .FALSE. @@ -680,7 +680,7 @@ subroutine rk_stratiform_tend( & call physics_ptend_init(ptend_all, state%psetcols, 'stratiform') call physics_ptend_sum( ptend_loc, ptend_all, ncol ) - ! Update physics state type state1 with ptend_loc + ! Update physics state type state1 with ptend_loc call physics_update( state1, ptend_loc, dtime ) call t_stopf('stratiform_sediment') @@ -695,13 +695,13 @@ subroutine rk_stratiform_tend( & ! Put all of the detraining cloud water from convection into the large scale cloud. ! It all goes in liquid for the moment. - ! Strictly speaking, this approach is detraining all the cconvective water into + ! Strictly speaking, this approach is detraining all the cconvective water into ! the environment, not the large-scale cloud. lq(:) = .FALSE. lq(ixcldliq) = .TRUE. call physics_ptend_init( ptend_loc, state1%psetcols, 'pcwdetrain', lq=lq) - + do k = 1, pver do i = 1, state1%ncol ptend_loc%q(i,k,ixcldliq) = dlf(i,k) @@ -725,7 +725,7 @@ subroutine rk_stratiform_tend( & ! -------------------------------------- ! ! ----------------------------------------------------------------------------- ! - ! Treatment of cloud fraction in CAM4 and CAM5 differs ! + ! Treatment of cloud fraction in CAM4 and CAM5 differs ! ! (1) CAM4 ! ! . Cumulus AMT = Deep Cumulus AMT ( empirical fcn of mass flux ) + ! ! Shallow Cumulus AMT ( empirical fcn of mass flux ) ! @@ -738,7 +738,7 @@ subroutine rk_stratiform_tend( & ! . Stratus AMT = fcn of environmental-mean RH ( no Stability Stratus ) ! ! . Cumulus and Stratus are non-overlapped with higher priority on Cumulus ! ! . Cumulus ( both Deep and Shallow ) has its own LWC and IWC. ! - ! ----------------------------------------------------------------------------- ! + ! ----------------------------------------------------------------------------- ! if( use_shfrc ) then call pbuf_get_field(pbuf, shfrc_idx, shfrc ) @@ -748,8 +748,8 @@ subroutine rk_stratiform_tend( & endif ! Stratus ('ast' = max(alst,aist)) and total cloud fraction ('cld = ast + concld') - ! will be computed using this updated 'concld' in the stratiform macrophysics - ! scheme (mmacro_pcond) later below. + ! will be computed using this updated 'concld' in the stratiform macrophysics + ! scheme (mmacro_pcond) later below. call t_startf("cldfrc") call cldfrc( lchnk, ncol, pbuf, & @@ -759,7 +759,7 @@ subroutine rk_stratiform_tend( & cmfmc, cmfmc_sh, landfrac,snowh, concld, cldst, & ts, sst, state1%pint(:,pverp), zdu, ocnfrac, rhu00, & state1%q(:,:,ixcldice), icecldf, liqcldf, & - relhum, 0 ) + relhum, 0 ) ! Re-calculate cloud with perturbed rh add call cldfrc to estimate rhdfda. @@ -770,7 +770,7 @@ subroutine rk_stratiform_tend( & cmfmc, cmfmc_sh, landfrac, snowh, concld2, cldst2, & ts, sst, state1%pint(:,pverp), zdu, ocnfrac, rhu002, & state1%q(:,:,ixcldice), icecldf2, liqcldf2, & - relhum2, 1 ) + relhum2, 1 ) call t_stopf("cldfrc") @@ -785,7 +785,7 @@ subroutine rk_stratiform_tend( & ! Under certain circumstances, rh+ cause cld not to changed ! when at an upper limit, or w/ strong subsidence if( ( cld2(i,k) - cld(i,k) ) < 1.e-4_r8 ) then - rhdfda(i,k) = 0.01_r8*relhum(i,k)*1.e+4_r8 + rhdfda(i,k) = 0.01_r8*relhum(i,k)*1.e+4_r8 else rhdfda(i,k) = 0.01_r8*relhum(i,k)/(cld2(i,k)-cld(i,k)) endif @@ -802,13 +802,17 @@ subroutine rk_stratiform_tend( & rdtime = 1._r8/dtime ! Define fractional amount of stratus condensate and precipitation in ice phase. - ! This uses a ramp ( -30 ~ -10 for fice, -5 ~ 0 for fsnow ). + ! This uses a ramp ( -30 ~ -10 for fice, -5 ~ 0 for fsnow ). ! The ramp within convective cloud may be different - call cldfrc_fice(ncol, state1%t, fice, fsnow) +!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + fice(:,:) = 0._r8 + fsnow(:,:) = 0._r8 +!REMOVECAM_END + call cldfrc_fice(ncol, state1%t(1:ncol,:), fice(1:ncol,:), fsnow(1:ncol,:)) - ! Perform repartitioning of stratiform condensate. - ! Corresponding heating tendency will be added later. + ! Perform repartitioning of stratiform condensate. + ! Corresponding heating tendency will be added later. lq(:) = .FALSE. lq(ixcldice) = .true. @@ -830,7 +834,7 @@ subroutine rk_stratiform_tend( & repartht(:ncol,:pver) = (latice/dtime) * ( state1%q(:ncol,:pver,ixcldice) - repartht(:ncol,:pver) ) - ! Non-micro and non-macrophysical external advective forcings to compute net condensation rate. + ! Non-micro and non-macrophysical external advective forcings to compute net condensation rate. ! Note that advective forcing of condensate is aggregated into liquid phase. qtend(:ncol,:pver) = ( state1%q(:ncol,:pver,1) - qcwat(:ncol,:pver) ) * rdtime @@ -869,7 +873,7 @@ subroutine rk_stratiform_tend( & ptend_loc%q(i,k,ixcldliq) = qme(i,k)*(1._r8-fice(i,k)) - liq2pr(i,k) end do end do - + do k = 1, pver do i = 1, ncol ast(i,k) = cld(i,k) @@ -960,7 +964,7 @@ subroutine rk_stratiform_tend( & cmfmc, cmfmc_sh, landfrac, snowh, concld, cldst, & ts, sst, state1%pint(:,pverp), zdu, ocnfrac, rhu00, & state1%q(:,:,ixcldice), icecldf, liqcldf, & - relhum, 0 ) + relhum, 0 ) call t_stopf("cldfrc") endif @@ -968,7 +972,7 @@ subroutine rk_stratiform_tend( & call outfld( 'CONCLD ', concld, pcols, lchnk ) call outfld( 'CLDST ', cldst, pcols, lchnk ) call outfld( 'CNVCLD ', clc, pcols, lchnk ) - call outfld( 'AST', ast, pcols, lchnk ) + call outfld( 'AST', ast, pcols, lchnk ) do k = 1, pver do i = 1, ncol @@ -1000,7 +1004,7 @@ subroutine rk_stratiform_tend( & tcwat(:ncol,k) = state1%t(:ncol,k) lcwat(:ncol,k) = state1%q(:ncol,k,ixcldice) + state1%q(:ncol,k,ixcldliq) end do - + ! Cloud water and ice particle sizes, saved in physics buffer for radiation call cldefr( lchnk, ncol, landfrac, state1%t, rel, rei, state1%ps, state1%pmid, landm, icefrac, snowh ) @@ -1025,7 +1029,7 @@ subroutine debug_microphys_1(state1,ptend,i,k, & use physconst, only: tmelt implicit none - + integer, intent(in) :: i,k type(physics_state), intent(in) :: state1 ! local copy of the state variable type(physics_ptend), intent(in) :: ptend ! local copy of the ptend variable @@ -1058,11 +1062,11 @@ subroutine debug_microphys_1(state1,ptend,i,k, & wv = 0 wi = 0 wlf = 0 - wvf = 0 + wvf = 0 wif = 0 - write(iulog,*) + write(iulog,*) write(iulog,*) ' input state, t, q, l, i ', k, state1%t(i,k), state1%q(i,k,1), state1%q(i,k,ixcldliq), state1%q(i,k,ixcldice) write(iulog,*) ' rain, snow, total from components before accumulation ', qr1, qs1, qr1+qs1 write(iulog,*) ' total precip before accumulation ', k, pr1 @@ -1143,7 +1147,7 @@ subroutine debug_microphys_1(state1,ptend,i,k, & ! + evapheat(i,k) + prfzheat(i,k) + meltheat(i,k) res = qs1+qr1-pr1 - w4 = max(abs(qs1),abs(qr1),abs(pr1)) + w4 = max(abs(qs1),abs(qr1),abs(pr1)) if (w4.gt.0._r8) then if (res/w4.gt.1.e-14_r8) then write(iulog,*) ' imbalance in precips calculated two ways ' @@ -1173,14 +1177,14 @@ subroutine debug_microphys_2(state1,& use ppgrid, only: pver use physconst, only: tmelt use physics_types, only: physics_state - + implicit none type(physics_state), intent(in) :: state1 ! local copy of the state variable real(r8), intent(in) :: snow_pcw(pcols) - real(r8), intent(in) :: fsaut(pcols,pver) - real(r8), intent(in) :: fsacw(pcols,pver) - real(r8), intent(in) :: fsaci(pcols,pver) + real(r8), intent(in) :: fsaut(pcols,pver) + real(r8), intent(in) :: fsacw(pcols,pver) + real(r8), intent(in) :: fsaci(pcols,pver) real(r8), intent(in) :: meltheat(pcols,pver) ! heating rate due to phase change of precip @@ -1189,7 +1193,7 @@ subroutine debug_microphys_2(state1,& ncol = state1%ncol lchnk = state1%lchnk - + do i = 1,ncol if (snow_pcw(i) .gt. 0.01_r8/8.64e4_r8 .and. state1%t(i,pver) .gt. tmelt) then write(iulog,*) ' stratiform: snow, temp, ', i, lchnk, & @@ -1201,7 +1205,7 @@ subroutine debug_microphys_2(state1,& write(iulog,*) ' meltheat ', meltheat(i,:) call endrun ('STRATIFORM_TEND') endif - + if (snow_pcw(i)*8.64e4_r8 .lt. -1.e-5_r8) then write(iulog,*) ' neg snow ', snow_pcw(i)*8.64e4_r8 write(iulog,*) ' stratiform: snow_pcw, temp, ', i, lchnk, & @@ -1214,7 +1218,7 @@ subroutine debug_microphys_2(state1,& call endrun ('STRATIFORM_TEND') endif end do - + end subroutine debug_microphys_2 end module rk_stratiform diff --git a/src/physics/cam/zm_conv.F90 b/src/physics/cam/zm_conv.F90 deleted file mode 100644 index 6305f6ba6d..0000000000 --- a/src/physics/cam/zm_conv.F90 +++ /dev/null @@ -1,4825 +0,0 @@ -module zm_conv - -!--------------------------------------------------------------------------------- -! Purpose: -! -! Interface from Zhang-McFarlane convection scheme, includes evaporation of convective -! precip from the ZM scheme -! -! Apr 2006: RBN: Code added to perform a dilute ascent for closure of the CM mass flux -! based on an entraining plume a la Raymond and Blythe (1992) -! -! Author: Byron Boville, from code in tphysbc -! -!--------------------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8 - use spmd_utils, only: masterproc - use ppgrid, only: pcols, pver, pverp - use cloud_fraction, only: cldfrc_fice - use physconst, only: cpair, epsilo, gravit, latice, latvap, tmelt, rair, & - cpwv, cpliq, rh2o - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use zm_microphysics, only: zm_mphy, zm_aero_t, zm_conv_t - use cam_history, only: outfld - - implicit none - - save - private ! Make default type private to the module -! -! PUBLIC: interfaces -! - public zm_convi ! ZM schemea - public zm_convr ! ZM schemea - public zm_conv_evap ! evaporation of precip from ZM schemea - public convtran ! convective transport - public momtran ! convective momentum transport - -! -! Private data -! - real(r8) rl ! wg latent heat of vaporization. - real(r8) cpres ! specific heat at constant pressure in j/kg-degk. - real(r8) :: capelmt ! namelist configurable: - ! threshold value for cape for deep convection. - real(r8) :: ke ! Tunable evaporation efficiency set from namelist input zmconv_ke - real(r8) :: ke_lnd - real(r8) :: c0_lnd ! set from namelist input zmconv_c0_lnd - real(r8) :: c0_ocn ! set from namelist input zmconv_c0_ocn - integer :: num_cin ! set from namelist input zmconv_num_cin - ! The number of negative buoyancy regions that are allowed - ! before the convection top and CAPE calculations are completed. - logical :: zm_org - real(r8) tau ! convective time scale - real(r8),parameter :: c1 = 6.112_r8 - real(r8),parameter :: c2 = 17.67_r8 - real(r8),parameter :: c3 = 243.5_r8 - real(r8) :: tfreez - real(r8) :: eps1 - real(r8) :: momcu - real(r8) :: momcd - - logical :: zmconv_microp - - logical :: no_deep_pbl ! default = .false. - ! no_deep_pbl = .true. eliminates deep convection entirely within PBL - - -!moved from moistconvection.F90 - real(r8) :: rgrav ! reciprocal of grav - real(r8) :: rgas ! gas constant for dry air - real(r8) :: grav ! = gravit - real(r8) :: cp ! = cpres = cpair - - integer limcnv ! top interface level limit for convection - - logical :: lparcel_pbl ! Switch to turn on mixing of parcel MSE air, and picking launch level to be the top of the PBL. - - - real(r8) :: tiedke_add ! namelist configurable - real(r8) :: dmpdz_param ! namelist configurable - -contains - - -subroutine zm_convi(limcnv_in, zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & - zmconv_momcu, zmconv_momcd, zmconv_num_cin, zmconv_org, & - zmconv_microp_in, no_deep_pbl_in, zmconv_tiedke_add, & - zmconv_capelmt, zmconv_dmpdz, zmconv_parcel_pbl, zmconv_tau) - - integer, intent(in) :: limcnv_in ! top interface level limit for convection - integer, intent(in) :: zmconv_num_cin ! Number negative buoyancy regions that are allowed - ! before the convection top and CAPE calculations are completed. - real(r8),intent(in) :: zmconv_c0_lnd - real(r8),intent(in) :: zmconv_c0_ocn - real(r8),intent(in) :: zmconv_ke - real(r8),intent(in) :: zmconv_ke_lnd - real(r8),intent(in) :: zmconv_momcu - real(r8),intent(in) :: zmconv_momcd - logical :: zmconv_org - logical, intent(in) :: zmconv_microp_in - logical, intent(in) :: no_deep_pbl_in ! no_deep_pbl = .true. eliminates ZM convection entirely within PBL - real(r8),intent(in) :: zmconv_tiedke_add - real(r8),intent(in) :: zmconv_capelmt - real(r8),intent(in) :: zmconv_dmpdz - logical, intent(in) :: zmconv_parcel_pbl ! Should the parcel properties include PBL mixing? - real(r8),intent(in) :: zmconv_tau - - ! Initialization of ZM constants - limcnv = limcnv_in - tfreez = tmelt - eps1 = epsilo - rl = latvap - cpres = cpair - rgrav = 1.0_r8/gravit - rgas = rair - grav = gravit - cp = cpres - - c0_lnd = zmconv_c0_lnd - c0_ocn = zmconv_c0_ocn - num_cin = zmconv_num_cin - ke = zmconv_ke - ke_lnd = zmconv_ke_lnd - zm_org = zmconv_org - momcu = zmconv_momcu - momcd = zmconv_momcd - - zmconv_microp = zmconv_microp_in - - tiedke_add = zmconv_tiedke_add - capelmt = zmconv_capelmt - dmpdz_param = zmconv_dmpdz - no_deep_pbl = no_deep_pbl_in - lparcel_pbl = zmconv_parcel_pbl - - tau = zmconv_tau - - if ( masterproc ) then - write(iulog,*) 'tuning parameters zm_convi: tau',tau - write(iulog,*) 'tuning parameters zm_convi: c0_lnd',c0_lnd, ', c0_ocn', c0_ocn - write(iulog,*) 'tuning parameters zm_convi: num_cin', num_cin - write(iulog,*) 'tuning parameters zm_convi: ke',ke - write(iulog,*) 'tuning parameters zm_convi: no_deep_pbl',no_deep_pbl - write(iulog,*) 'tuning parameters zm_convi: zm_capelmt', capelmt - write(iulog,*) 'tuning parameters zm_convi: zm_dmpdz', dmpdz_param - write(iulog,*) 'tuning parameters zm_convi: zm_tiedke_add', tiedke_add - write(iulog,*) 'tuning parameters zm_convi: zm_parcel_pbl', lparcel_pbl - endif - - if (masterproc) write(iulog,*)'**** ZM: DILUTE Buoyancy Calculation ****' - -end subroutine zm_convi - - - -subroutine zm_convr(lchnk ,ncol , & - t ,qh ,prec ,jctop ,jcbot , & - pblh ,zm ,geos ,zi ,qtnd , & - heat ,pap ,paph ,dpp , & - delt ,mcon ,cme ,cape , & - tpert ,dlf ,pflx ,zdu ,rprd , & - mu ,md ,du ,eu ,ed , & - dp ,dsubcld ,jt ,maxg ,ideep , & - ql ,rliq ,landfrac, & - org ,orgt ,org2d , & - dif ,dnlf ,dnif ,conv , & - aero , rice) -!----------------------------------------------------------------------- -! -! Purpose: -! Main driver for zhang-mcfarlane convection scheme -! -! Method: -! performs deep convective adjustment based on mass-flux closure -! algorithm. -! -! Author:guang jun zhang, m.lazare, n.mcfarlane. CAM Contact: P. Rasch -! -! This is contributed code not fully standardized by the CAM core group. -! All variables have been typed, where most are identified in comments -! The current procedure will be reimplemented in a subsequent version -! of the CAM where it will include a more straightforward formulation -! and will make use of the standard CAM nomenclature -! -!----------------------------------------------------------------------- - use phys_control, only: cam_physpkg_is - -! -! ************************ index of variables ********************** -! -! wg * alpha array of vertical differencing used (=1. for upstream). -! w * cape convective available potential energy. -! wg * capeg gathered convective available potential energy. -! c * capelmt threshold value for cape for deep convection. -! ic * cpres specific heat at constant pressure in j/kg-degk. -! i * dpp -! ic * delt length of model time-step in seconds. -! wg * dp layer thickness in mbs (between upper/lower interface). -! wg * dqdt mixing ratio tendency at gathered points. -! wg * dsdt dry static energy ("temp") tendency at gathered points. -! wg * dudt u-wind tendency at gathered points. -! wg * dvdt v-wind tendency at gathered points. -! wg * dsubcld layer thickness in mbs between lcl and maxi. -! ic * grav acceleration due to gravity in m/sec2. -! wg * du detrainment in updraft. specified in mid-layer -! wg * ed entrainment in downdraft. -! wg * eu entrainment in updraft. -! wg * hmn moist static energy. -! wg * hsat saturated moist static energy. -! w * ideep holds position of gathered points vs longitude index. -! ic * pver number of model levels. -! wg * j0 detrainment initiation level index. -! wg * jd downdraft initiation level index. -! ic * jlatpr gaussian latitude index for printing grids (if needed). -! wg * jt top level index of deep cumulus convection. -! w * lcl base level index of deep cumulus convection. -! wg * lclg gathered values of lcl. -! w * lel index of highest theoretical convective plume. -! wg * lelg gathered values of lel. -! w * lon index of onset level for deep convection. -! w * maxi index of level with largest moist static energy. -! wg * maxg gathered values of maxi. -! wg * mb cloud base mass flux. -! wg * mc net upward (scaled by mb) cloud mass flux. -! wg * md downward cloud mass flux (positive up). -! wg * mu upward cloud mass flux (positive up). specified -! at interface -! ic * msg number of missing moisture levels at the top of model. -! w * p grid slice of ambient mid-layer pressure in mbs. -! i * pblt row of pbl top indices. -! w * pcpdh scaled surface pressure. -! w * pf grid slice of ambient interface pressure in mbs. -! wg * pg grid slice of gathered values of p. -! w * q grid slice of mixing ratio. -! wg * qd grid slice of mixing ratio in downdraft. -! wg * qg grid slice of gathered values of q. -! i/o * qh grid slice of specific humidity. -! w * qh0 grid slice of initial specific humidity. -! wg * qhat grid slice of upper interface mixing ratio. -! wg * ql grid slice of cloud liquid water. -! wg * qs grid slice of saturation mixing ratio. -! w * qstp grid slice of parcel temp. saturation mixing ratio. -! wg * qstpg grid slice of gathered values of qstp. -! wg * qu grid slice of mixing ratio in updraft. -! ic * rgas dry air gas constant. -! wg * rl latent heat of vaporization. -! w * s grid slice of scaled dry static energy (t+gz/cp). -! wg * sd grid slice of dry static energy in downdraft. -! wg * sg grid slice of gathered values of s. -! wg * shat grid slice of upper interface dry static energy. -! wg * su grid slice of dry static energy in updraft. -! i/o * t -! o * jctop row of top-of-deep-convection indices passed out. -! O * jcbot row of base of cloud indices passed out. -! wg * tg grid slice of gathered values of t. -! w * tl row of parcel temperature at lcl. -! wg * tlg grid slice of gathered values of tl. -! w * tp grid slice of parcel temperatures. -! wg * tpg grid slice of gathered values of tp. -! i/o * u grid slice of u-wind (real). -! wg * ug grid slice of gathered values of u. -! i/o * utg grid slice of u-wind tendency (real). -! i/o * v grid slice of v-wind (real). -! w * va work array re-used by called subroutines. -! wg * vg grid slice of gathered values of v. -! i/o * vtg grid slice of v-wind tendency (real). -! i * w grid slice of diagnosed large-scale vertical velocity. -! w * z grid slice of ambient mid-layer height in metres. -! w * zf grid slice of ambient interface height in metres. -! wg * zfg grid slice of gathered values of zf. -! wg * zg grid slice of gathered values of z. -! -!----------------------------------------------------------------------- -! -! multi-level i/o fields: -! i => input arrays. -! i/o => input/output arrays. -! w => work arrays. -! wg => work arrays operating only on gathered points. -! ic => input data constants. -! c => data constants pertaining to subroutine itself. -! -! input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - - real(r8), intent(in) :: t(pcols,pver) ! grid slice of temperature at mid-layer. - real(r8), intent(in) :: qh(pcols,pver) ! grid slice of specific humidity. - real(r8), intent(in) :: pap(pcols,pver) - real(r8), intent(in) :: paph(pcols,pver+1) - real(r8), intent(in) :: dpp(pcols,pver) ! local sigma half-level thickness (i.e. dshj). - real(r8), intent(in) :: zm(pcols,pver) - real(r8), intent(in) :: geos(pcols) - real(r8), intent(in) :: zi(pcols,pver+1) - real(r8), intent(in) :: pblh(pcols) - real(r8), intent(in) :: tpert(pcols) - real(r8), intent(in) :: landfrac(pcols) ! RBN Landfrac - - type(zm_conv_t), intent(inout) :: conv - type(zm_aero_t), intent(inout) :: aero ! aerosol object. intent(inout) because the - ! gathered arrays are set here - ! before passing object - ! to microphysics -! output arguments -! - real(r8), intent(out) :: qtnd(pcols,pver) ! specific humidity tendency (kg/kg/s) - real(r8), intent(out) :: heat(pcols,pver) ! heating rate (dry static energy tendency, W/kg) - real(r8), intent(out) :: mcon(pcols,pverp) - real(r8), intent(out) :: dlf(pcols,pver) ! scattrd version of the detraining cld h2o tend - real(r8), intent(out) :: pflx(pcols,pverp) ! scattered precip flux at each level - real(r8), intent(out) :: cme(pcols,pver) - real(r8), intent(out) :: cape(pcols) ! w convective available potential energy. - real(r8), intent(out) :: zdu(pcols,pver) - real(r8), intent(out) :: rprd(pcols,pver) ! rain production rate - real(r8), intent(out) :: dif(pcols,pver) ! detrained convective cloud ice mixing ratio. - real(r8), intent(out) :: dnlf(pcols,pver) ! detrained convective cloud water num concen. - real(r8), intent(out) :: dnif(pcols,pver) ! detrained convective cloud ice num concen. - -! move these vars from local storage to output so that convective -! transports can be done in outside of conv_cam. - real(r8), intent(out) :: mu(pcols,pver) - real(r8), intent(out) :: eu(pcols,pver) - real(r8), intent(out) :: du(pcols,pver) - real(r8), intent(out) :: md(pcols,pver) - real(r8), intent(out) :: ed(pcols,pver) - real(r8), intent(out) :: dp(pcols,pver) ! wg layer thickness in mbs (between upper/lower interface). - real(r8), intent(out) :: dsubcld(pcols) ! wg layer thickness in mbs between lcl and maxi. - real(r8), intent(out) :: jctop(pcols) ! o row of top-of-deep-convection indices passed out. - real(r8), intent(out) :: jcbot(pcols) ! o row of base of cloud indices passed out. - real(r8), intent(out) :: prec(pcols) - real(r8), intent(out) :: rliq(pcols) ! reserved liquid (not yet in cldliq) for energy integrals - real(r8), intent(out) :: rice(pcols) ! reserved ice (not yet in cldce) for energy integrals - - integer, intent(out) :: ideep(pcols) ! column indices of gathered points - - type(zm_conv_t) :: loc_conv - - real(r8), pointer :: org(:,:) ! Only used if zm_org is true - real(r8), pointer :: orgt(:,:) ! Only used if zm_org is true - real(r8), pointer :: org2d(:,:) ! Only used if zm_org is true - - real(r8) zs(pcols) - real(r8) dlg(pcols,pver) ! gathrd version of the detraining cld h2o tend - real(r8) pflxg(pcols,pverp) ! gather precip flux at each level - real(r8) cug(pcols,pver) ! gathered condensation rate - - real(r8) evpg(pcols,pver) ! gathered evap rate of rain in downdraft - real(r8) orgavg(pcols) - real(r8) dptot(pcols) - real(r8) mumax(pcols) - integer jt(pcols) ! wg top level index of deep cumulus convection. - integer maxg(pcols) ! wg gathered values of maxi. - integer lengath -! diagnostic field used by chem/wetdep codes - real(r8) ql(pcols,pver) ! wg grid slice of cloud liquid water. -! - real(r8) pblt(pcols) ! i row of pbl top indices. - - - - -! -!----------------------------------------------------------------------- -! -! general work fields (local variables): -! - real(r8) q(pcols,pver) ! w grid slice of mixing ratio. - real(r8) p(pcols,pver) ! w grid slice of ambient mid-layer pressure in mbs. - real(r8) z(pcols,pver) ! w grid slice of ambient mid-layer height in metres. - real(r8) s(pcols,pver) ! w grid slice of scaled dry static energy (t+gz/cp). - real(r8) tp(pcols,pver) ! w grid slice of parcel temperatures. - real(r8) zf(pcols,pver+1) ! w grid slice of ambient interface height in metres. - real(r8) pf(pcols,pver+1) ! w grid slice of ambient interface pressure in mbs. - real(r8) qstp(pcols,pver) ! w grid slice of parcel temp. saturation mixing ratio. - - real(r8) tl(pcols) ! w row of parcel temperature at lcl. - - integer lcl(pcols) ! w base level index of deep cumulus convection. - integer lel(pcols) ! w index of highest theoretical convective plume. - integer lon(pcols) ! w index of onset level for deep convection. - integer maxi(pcols) ! w index of level with largest moist static energy. - - real(r8) precip -! -! gathered work fields: -! - real(r8) qg(pcols,pver) ! wg grid slice of gathered values of q. - real(r8) tg(pcols,pver) ! w grid slice of temperature at interface. - real(r8) pg(pcols,pver) ! wg grid slice of gathered values of p. - real(r8) zg(pcols,pver) ! wg grid slice of gathered values of z. - real(r8) sg(pcols,pver) ! wg grid slice of gathered values of s. - real(r8) tpg(pcols,pver) ! wg grid slice of gathered values of tp. - real(r8) zfg(pcols,pver+1) ! wg grid slice of gathered values of zf. - real(r8) qstpg(pcols,pver) ! wg grid slice of gathered values of qstp. - real(r8) ug(pcols,pver) ! wg grid slice of gathered values of u. - real(r8) vg(pcols,pver) ! wg grid slice of gathered values of v. - real(r8) cmeg(pcols,pver) - - real(r8) rprdg(pcols,pver) ! wg gathered rain production rate - real(r8) capeg(pcols) ! wg gathered convective available potential energy. - real(r8) tlg(pcols) ! wg grid slice of gathered values of tl. - real(r8) landfracg(pcols) ! wg grid slice of landfrac - - integer lclg(pcols) ! wg gathered values of lcl. - integer lelg(pcols) -! -! work fields arising from gathered calculations. -! - real(r8) dqdt(pcols,pver) ! wg mixing ratio tendency at gathered points. - real(r8) dsdt(pcols,pver) ! wg dry static energy ("temp") tendency at gathered points. -! real(r8) alpha(pcols,pver) ! array of vertical differencing used (=1. for upstream). - real(r8) sd(pcols,pver) ! wg grid slice of dry static energy in downdraft. - real(r8) qd(pcols,pver) ! wg grid slice of mixing ratio in downdraft. - real(r8) mc(pcols,pver) ! wg net upward (scaled by mb) cloud mass flux. - real(r8) qhat(pcols,pver) ! wg grid slice of upper interface mixing ratio. - real(r8) qu(pcols,pver) ! wg grid slice of mixing ratio in updraft. - real(r8) su(pcols,pver) ! wg grid slice of dry static energy in updraft. - real(r8) qs(pcols,pver) ! wg grid slice of saturation mixing ratio. - real(r8) shat(pcols,pver) ! wg grid slice of upper interface dry static energy. - real(r8) hmn(pcols,pver) ! wg moist static energy. - real(r8) hsat(pcols,pver) ! wg saturated moist static energy. - real(r8) qlg(pcols,pver) - real(r8) dudt(pcols,pver) ! wg u-wind tendency at gathered points. - real(r8) dvdt(pcols,pver) ! wg v-wind tendency at gathered points. -! real(r8) ud(pcols,pver) -! real(r8) vd(pcols,pver) - - - - - - - - real(r8) qldeg(pcols,pver) ! cloud liquid water mixing ratio for detrainment (kg/kg) - real(r8) mb(pcols) ! wg cloud base mass flux. - - integer jlcl(pcols) - integer j0(pcols) ! wg detrainment initiation level index. - integer jd(pcols) ! wg downdraft initiation level index. - - real(r8) delt ! length of model time-step in seconds. - - integer i - integer ii - integer k, kk, l, m - - integer msg ! ic number of missing moisture levels at the top of model. - real(r8) qdifr - real(r8) sdifr - - real(r8), parameter :: dcon = 25.e-6_r8 - real(r8), parameter :: mucon = 5.3_r8 - real(r8) negadq - logical doliq - - -! -!--------------------------Data statements------------------------------ - -! -! Set internal variable "msg" (convection limit) to "limcnv-1" -! - msg = limcnv - 1 -! -! initialize necessary arrays. -! zero out variables not used in cam -! - - if (zm_org) then - orgt(:,:) = 0._r8 - end if - - qtnd(:,:) = 0._r8 - heat(:,:) = 0._r8 - mcon(:,:) = 0._r8 - rliq(:ncol) = 0._r8 - rice(:ncol) = 0._r8 - - if (zmconv_microp) then - allocate( & - loc_conv%frz(pcols,pver), & - loc_conv%sprd(pcols,pver), & - loc_conv%wu(pcols,pver), & - loc_conv%qi(pcols,pver), & - loc_conv%qliq(pcols,pver), & - loc_conv%qice(pcols,pver), & - loc_conv%qrain(pcols,pver), & - loc_conv%qsnow(pcols,pver), & - loc_conv%di(pcols,pver), & - loc_conv%dnl(pcols,pver), & - loc_conv%dni(pcols,pver), & - loc_conv%qnl(pcols,pver), & - loc_conv%qni(pcols,pver), & - loc_conv%qnr(pcols,pver), & - loc_conv%qns(pcols,pver), & - loc_conv%qide(pcols,pver), & - loc_conv%qncde(pcols,pver), & - loc_conv%qnide(pcols,pver), & - loc_conv%autolm(pcols,pver), & - loc_conv%accrlm(pcols,pver), & - loc_conv%bergnm(pcols,pver), & - loc_conv%fhtimm(pcols,pver), & - loc_conv%fhtctm(pcols,pver), & - loc_conv%fhmlm(pcols,pver), & - loc_conv%hmpim(pcols,pver), & - loc_conv%accslm(pcols,pver), & - loc_conv%dlfm(pcols,pver), & - loc_conv%cmel(pcols,pver), & - loc_conv%autoln(pcols,pver), & - loc_conv%accrln(pcols,pver), & - loc_conv%bergnn(pcols,pver), & - loc_conv%fhtimn(pcols,pver), & - loc_conv%fhtctn(pcols,pver), & - loc_conv%fhmln(pcols,pver), & - loc_conv%accsln(pcols,pver), & - loc_conv%activn(pcols,pver), & - loc_conv%dlfn(pcols,pver), & - loc_conv%autoim(pcols,pver), & - loc_conv%accsim(pcols,pver), & - loc_conv%difm(pcols,pver), & - loc_conv%cmei(pcols,pver), & - loc_conv%nuclin(pcols,pver), & - loc_conv%autoin(pcols,pver), & - loc_conv%accsin(pcols,pver), & - loc_conv%hmpin(pcols,pver), & - loc_conv%difn(pcols,pver), & - loc_conv%trspcm(pcols,pver), & - loc_conv%trspcn(pcols,pver), & - loc_conv%trspim(pcols,pver), & - loc_conv%trspin(pcols,pver), & - loc_conv%lambdadpcu(pcols,pver), & - loc_conv%mudpcu(pcols,pver), & - loc_conv%dcape(pcols) ) - end if - -! -! initialize convective tendencies -! - prec(:ncol) = 0._r8 - do k = 1,pver - do i = 1,ncol - dqdt(i,k) = 0._r8 - dsdt(i,k) = 0._r8 - dudt(i,k) = 0._r8 - dvdt(i,k) = 0._r8 - pflx(i,k) = 0._r8 - pflxg(i,k) = 0._r8 - cme(i,k) = 0._r8 - rprd(i,k) = 0._r8 - zdu(i,k) = 0._r8 - ql(i,k) = 0._r8 - qlg(i,k) = 0._r8 - dlf(i,k) = 0._r8 - dlg(i,k) = 0._r8 - qldeg(i,k) = 0._r8 - - dif(i,k) = 0._r8 - dnlf(i,k) = 0._r8 - dnif(i,k) = 0._r8 - - end do - end do - - if (zmconv_microp) then - do k = 1,pver - do i = 1,ncol - loc_conv%qliq(i,k) = 0._r8 - loc_conv%qice(i,k) = 0._r8 - loc_conv%di(i,k) = 0._r8 - loc_conv%qrain(i,k)= 0._r8 - loc_conv%qsnow(i,k)= 0._r8 - loc_conv%dnl(i,k) = 0._r8 - loc_conv%dni(i,k) = 0._r8 - loc_conv%wu(i,k) = 0._r8 - loc_conv%qnl(i,k) = 0._r8 - loc_conv%qni(i,k) = 0._r8 - loc_conv%qnr(i,k) = 0._r8 - loc_conv%qns(i,k) = 0._r8 - loc_conv%frz(i,k) = 0._r8 - loc_conv%sprd(i,k) = 0._r8 - loc_conv%qide(i,k) = 0._r8 - loc_conv%qncde(i,k) = 0._r8 - loc_conv%qnide(i,k) = 0._r8 - - loc_conv%autolm(i,k) = 0._r8 - loc_conv%accrlm(i,k) = 0._r8 - loc_conv%bergnm(i,k) = 0._r8 - loc_conv%fhtimm(i,k) = 0._r8 - loc_conv%fhtctm(i,k) = 0._r8 - loc_conv%fhmlm (i,k) = 0._r8 - loc_conv%hmpim (i,k) = 0._r8 - loc_conv%accslm(i,k) = 0._r8 - loc_conv%dlfm (i,k) = 0._r8 - - loc_conv%autoln(i,k) = 0._r8 - loc_conv%accrln(i,k) = 0._r8 - loc_conv%bergnn(i,k) = 0._r8 - loc_conv%fhtimn(i,k) = 0._r8 - loc_conv%fhtctn(i,k) = 0._r8 - loc_conv%fhmln (i,k) = 0._r8 - loc_conv%accsln(i,k) = 0._r8 - loc_conv%activn(i,k) = 0._r8 - loc_conv%dlfn (i,k) = 0._r8 - loc_conv%cmel (i,k) = 0._r8 - - loc_conv%autoim(i,k) = 0._r8 - loc_conv%accsim(i,k) = 0._r8 - loc_conv%difm (i,k) = 0._r8 - loc_conv%cmei (i,k) = 0._r8 - - loc_conv%nuclin(i,k) = 0._r8 - loc_conv%autoin(i,k) = 0._r8 - loc_conv%accsin(i,k) = 0._r8 - loc_conv%hmpin (i,k) = 0._r8 - loc_conv%difn (i,k) = 0._r8 - - loc_conv%trspcm(i,k) = 0._r8 - loc_conv%trspcn(i,k) = 0._r8 - loc_conv%trspim(i,k) = 0._r8 - loc_conv%trspin(i,k) = 0._r8 - - conv%qi(i,k) = 0._r8 - conv%frz(i,k) = 0._r8 - conv%sprd(i,k) = 0._r8 - conv%qi(i,k) = 0._r8 - conv%qliq(i,k) = 0._r8 - conv%qice(i,k) = 0._r8 - conv%qnl(i,k) = 0._r8 - conv%qni(i,k) = 0._r8 - conv%qnr(i,k) = 0._r8 - conv%qns(i,k) = 0._r8 - conv%qrain(i,k) = 0._r8 - conv%qsnow(i,k) = 0._r8 - conv%wu(i,k) = 0._r8 - - conv%autolm(i,k) = 0._r8 - conv%accrlm(i,k) = 0._r8 - conv%bergnm(i,k) = 0._r8 - conv%fhtimm(i,k) = 0._r8 - conv%fhtctm(i,k) = 0._r8 - conv%fhmlm (i,k) = 0._r8 - conv%hmpim (i,k) = 0._r8 - conv%accslm(i,k) = 0._r8 - conv%dlfm (i,k) = 0._r8 - - conv%autoln(i,k) = 0._r8 - conv%accrln(i,k) = 0._r8 - conv%bergnn(i,k) = 0._r8 - conv%fhtimn(i,k) = 0._r8 - conv%fhtctn(i,k) = 0._r8 - conv%fhmln (i,k) = 0._r8 - conv%accsln(i,k) = 0._r8 - conv%activn(i,k) = 0._r8 - conv%dlfn (i,k) = 0._r8 - conv%cmel (i,k) = 0._r8 - - conv%autoim(i,k) = 0._r8 - conv%accsim(i,k) = 0._r8 - conv%difm (i,k) = 0._r8 - conv%cmei (i,k) = 0._r8 - - conv%nuclin(i,k) = 0._r8 - conv%autoin(i,k) = 0._r8 - conv%accsin(i,k) = 0._r8 - conv%hmpin (i,k) = 0._r8 - conv%difn (i,k) = 0._r8 - - conv%trspcm(i,k) = 0._r8 - conv%trspcn(i,k) = 0._r8 - conv%trspim(i,k) = 0._r8 - conv%trspin(i,k) = 0._r8 - - end do - end do - - conv%lambdadpcu = (mucon + 1._r8)/dcon - conv%mudpcu = mucon - loc_conv%lambdadpcu = conv%lambdadpcu - loc_conv%mudpcu = conv%mudpcu - - end if - - do i = 1,ncol - pflx(i,pverp) = 0 - pflxg(i,pverp) = 0 - end do -! - do i = 1,ncol - pblt(i) = pver - dsubcld(i) = 0._r8 - - - jctop(i) = pver - jcbot(i) = 1 - - end do - - if (zmconv_microp) then - do i = 1,ncol - conv%dcape(i) = 0._r8 - loc_conv%dcape(i) = 0._r8 - end do - end if - - if (zm_org) then -! compute vertical average here - orgavg(:) = 0._r8 - dptot(:) = 0._r8 - - do k = 1, pver - do i = 1,ncol - if (org(i,k) .gt. 0) then - orgavg(i) = orgavg(i)+dpp(i,k)*org(i,k) - dptot(i) = dptot(i)+dpp(i,k) - endif - enddo - enddo - - do i = 1,ncol - if (dptot(i) .gt. 0) then - orgavg(i) = orgavg(i)/dptot(i) - endif - enddo - - do k = 1, pver - do i = 1, ncol - org2d(i,k) = orgavg(i) - enddo - enddo - - endif - -! -! calculate local pressure (mbs) and height (m) for both interface -! and mid-layer locations. -! - do i = 1,ncol - zs(i) = geos(i)*rgrav - pf(i,pver+1) = paph(i,pver+1)*0.01_r8 - zf(i,pver+1) = zi(i,pver+1) + zs(i) - end do - do k = 1,pver - do i = 1,ncol - p(i,k) = pap(i,k)*0.01_r8 - pf(i,k) = paph(i,k)*0.01_r8 - z(i,k) = zm(i,k) + zs(i) - zf(i,k) = zi(i,k) + zs(i) - end do - end do -! - do k = pver - 1,msg + 1,-1 - do i = 1,ncol - if (abs(z(i,k)-zs(i)-pblh(i)) < (zf(i,k)-zf(i,k+1))*0.5_r8) pblt(i) = k - end do - end do -! -! store incoming specific humidity field for subsequent calculation -! of precipitation (through change in storage). -! define dry static energy (normalized by cp). -! - do k = 1,pver - do i = 1,ncol - q(i,k) = qh(i,k) - s(i,k) = t(i,k) + (grav/cpres)*z(i,k) - tp(i,k)=0.0_r8 - shat(i,k) = s(i,k) - qhat(i,k) = q(i,k) - end do - end do - - do i = 1,ncol - capeg(i) = 0._r8 - lclg(i) = 1 - lelg(i) = pver - maxg(i) = 1 - tlg(i) = 400._r8 - dsubcld(i) = 0._r8 - end do - - if( cam_physpkg_is('cam3')) then - - ! For cam3 physics package, call non-dilute - - call buoyan(lchnk ,ncol , & - q ,t ,p ,z ,pf , & - tp ,qstp ,tl ,rl ,cape , & - pblt ,lcl ,lel ,lon ,maxi , & - rgas ,grav ,cpres ,msg , & - tpert ) - else - - ! Evaluate Tparcel, qs(Tparcel), buoyancy and CAPE, - ! lcl, lel, parcel launch level at index maxi()=hmax - - call buoyan_dilute(lchnk ,ncol , & - q ,t ,p ,z ,pf , & - tp ,qstp ,tl ,rl ,cape , & - pblt ,lcl ,lel ,lon ,maxi , & - rgas ,grav ,cpres ,msg , & - zi ,zs ,tpert , org2d , landfrac) - end if - -! -! determine whether grid points will undergo some deep convection -! (ideep=1) or not (ideep=0), based on values of cape,lcl,lel -! (require cape.gt. 0 and lel capelmt) then - lengath = lengath + 1 - ideep(lengath) = i - end if - end do - - if (lengath.eq.0) return -! -! obtain gathered arrays necessary for ensuing calculations. -! - do k = 1,pver - do i = 1,lengath - dp(i,k) = 0.01_r8*dpp(ideep(i),k) - qg(i,k) = q(ideep(i),k) - tg(i,k) = t(ideep(i),k) - pg(i,k) = p(ideep(i),k) - zg(i,k) = z(ideep(i),k) - sg(i,k) = s(ideep(i),k) - tpg(i,k) = tp(ideep(i),k) - zfg(i,k) = zf(ideep(i),k) - qstpg(i,k) = qstp(ideep(i),k) - ug(i,k) = 0._r8 - vg(i,k) = 0._r8 - end do - end do - - if (zmconv_microp) then - - if (aero%scheme == 'modal') then - - do m = 1, aero%nmodes - - do k = 1,pver - do i = 1,lengath - aero%numg_a(i,k,m) = aero%num_a(m)%val(ideep(i),k) - aero%dgnumg(i,k,m) = aero%dgnum(m)%val(ideep(i),k) - end do - end do - - do l = 1, aero%nspec(m) - do k = 1,pver - do i = 1,lengath - aero%mmrg_a(i,k,l,m) = aero%mmr_a(l,m)%val(ideep(i),k) - end do - end do - end do - - end do - - else if (aero%scheme == 'bulk') then - - do m = 1, aero%nbulk - do k = 1,pver - do i = 1,lengath - aero%mmrg_bulk(i,k,m) = aero%mmr_bulk(m)%val(ideep(i),k) - end do - end do - end do - - end if - - end if - -! - do i = 1,lengath - zfg(i,pver+1) = zf(ideep(i),pver+1) - end do - do i = 1,lengath - capeg(i) = cape(ideep(i)) - lclg(i) = lcl(ideep(i)) - lelg(i) = lel(ideep(i)) - maxg(i) = maxi(ideep(i)) - tlg(i) = tl(ideep(i)) - landfracg(i) = landfrac(ideep(i)) - end do -! -! calculate sub-cloud layer pressure "thickness" for use in -! closure and tendency routines. -! - do k = msg + 1,pver - do i = 1,lengath - if (k >= maxg(i)) then - dsubcld(i) = dsubcld(i) + dp(i,k) - end if - end do - end do -! -! define array of factors (alpha) which defines interfacial -! values, as well as interfacial values for (q,s) used in -! subsequent routines. -! - do k = msg + 2,pver - do i = 1,lengath -! alpha(i,k) = 0.5 - sdifr = 0._r8 - qdifr = 0._r8 - if (sg(i,k) > 0._r8 .or. sg(i,k-1) > 0._r8) & - sdifr = abs((sg(i,k)-sg(i,k-1))/max(sg(i,k-1),sg(i,k))) - if (qg(i,k) > 0._r8 .or. qg(i,k-1) > 0._r8) & - qdifr = abs((qg(i,k)-qg(i,k-1))/max(qg(i,k-1),qg(i,k))) - if (sdifr > 1.E-6_r8) then - shat(i,k) = log(sg(i,k-1)/sg(i,k))*sg(i,k-1)*sg(i,k)/(sg(i,k-1)-sg(i,k)) - else - shat(i,k) = 0.5_r8* (sg(i,k)+sg(i,k-1)) - end if - if (qdifr > 1.E-6_r8) then - qhat(i,k) = log(qg(i,k-1)/qg(i,k))*qg(i,k-1)*qg(i,k)/(qg(i,k-1)-qg(i,k)) - else - qhat(i,k) = 0.5_r8* (qg(i,k)+qg(i,k-1)) - end if - end do - end do -! -! obtain cloud properties. -! - - call cldprp(lchnk , & - qg ,tg ,ug ,vg ,pg , & - zg ,sg ,mu ,eu ,du , & - md ,ed ,sd ,qd ,mc , & - qu ,su ,zfg ,qs ,hmn , & - hsat ,shat ,qlg , & - cmeg ,maxg ,lelg ,jt ,jlcl , & - maxg ,j0 ,jd ,rl ,lengath , & - rgas ,grav ,cpres ,msg , & - pflxg ,evpg ,cug ,rprdg ,limcnv ,landfracg , & - qldeg ,aero ,loc_conv,qhat ) - - if (zmconv_microp) then - do i = 1,lengath - capeg(i) = capeg(i)+ loc_conv%dcape(i) - end do - end if - -! -! convert detrainment from units of "1/m" to "1/mb". -! - - do k = msg + 1,pver - do i = 1,lengath - du (i,k) = du (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - eu (i,k) = eu (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - ed (i,k) = ed (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - cug (i,k) = cug (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - cmeg (i,k) = cmeg (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - rprdg(i,k) = rprdg(i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - evpg (i,k) = evpg (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - end do - end do - - if (zmconv_microp) then - do k = msg + 1,pver - do i = 1,lengath - loc_conv%sprd(i,k) = loc_conv%sprd(i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - loc_conv%frz (i,k) = loc_conv%frz (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) - end do - end do - end if - - call closure(lchnk , & - qg ,tg ,pg ,zg ,sg , & - tpg ,qs ,qu ,su ,mc , & - du ,mu ,md ,qd ,sd , & - qhat ,shat ,dp ,qstpg ,zfg , & - qlg ,dsubcld ,mb ,capeg ,tlg , & - lclg ,lelg ,jt ,maxg ,1 , & - lengath ,rgas ,grav ,cpres ,rl , & - msg ,capelmt ) -! -! limit cloud base mass flux to theoretical upper bound. -! - do i=1,lengath - mumax(i) = 0 - end do - do k=msg + 2,pver - do i=1,lengath - mumax(i) = max(mumax(i), mu(i,k)/dp(i,k)) - end do - end do - - do i=1,lengath - if (mumax(i) > 0._r8) then - mb(i) = min(mb(i),0.5_r8/(delt*mumax(i))) - else - mb(i) = 0._r8 - endif - end do - ! If no_deep_pbl = .true., don't allow convection entirely - ! within PBL (suggestion of Bjorn Stevens, 8-2000) - - if (no_deep_pbl) then - do i=1,lengath - if (zm(ideep(i),jt(i)) < pblh(ideep(i))) mb(i) = 0 - end do - end if - - if (zmconv_microp) then - do k=msg+1,pver - do i=1,lengath - loc_conv%sprd(i,k) = loc_conv%sprd(i,k)*mb(i) - loc_conv%frz (i,k) = loc_conv%frz (i,k)*mb(i) - end do - end do - end if - - do k=msg+1,pver - do i=1,lengath - mu (i,k) = mu (i,k)*mb(i) - md (i,k) = md (i,k)*mb(i) - mc (i,k) = mc (i,k)*mb(i) - du (i,k) = du (i,k)*mb(i) - eu (i,k) = eu (i,k)*mb(i) - ed (i,k) = ed (i,k)*mb(i) - cmeg (i,k) = cmeg (i,k)*mb(i) - rprdg(i,k) = rprdg(i,k)*mb(i) - cug (i,k) = cug (i,k)*mb(i) - evpg (i,k) = evpg (i,k)*mb(i) - pflxg(i,k+1)= pflxg(i,k+1)*mb(i)*100._r8/grav - - - if ( zmconv_microp .and. mb(i).eq.0._r8) then - qlg (i,k) = 0._r8 - loc_conv%qliq (i,k) = 0._r8 - loc_conv%qice (i,k) = 0._r8 - loc_conv%qrain(i,k) = 0._r8 - loc_conv%qsnow(i,k) = 0._r8 - loc_conv%wu(i,k) = 0._r8 - loc_conv%qnl (i,k) = 0._r8 - loc_conv%qni (i,k) = 0._r8 - loc_conv%qnr (i,k) = 0._r8 - loc_conv%qns (i,k) = 0._r8 - - loc_conv%autolm(i,k) = 0._r8 - loc_conv%accrlm(i,k) = 0._r8 - loc_conv%bergnm(i,k) = 0._r8 - loc_conv%fhtimm(i,k) = 0._r8 - loc_conv%fhtctm(i,k) = 0._r8 - loc_conv%fhmlm (i,k) = 0._r8 - loc_conv%hmpim (i,k) = 0._r8 - loc_conv%accslm(i,k) = 0._r8 - loc_conv%dlfm (i,k) = 0._r8 - - loc_conv%autoln(i,k) = 0._r8 - loc_conv%accrln(i,k) = 0._r8 - loc_conv%bergnn(i,k) = 0._r8 - loc_conv%fhtimn(i,k) = 0._r8 - loc_conv%fhtctn(i,k) = 0._r8 - loc_conv%fhmln (i,k) = 0._r8 - loc_conv%accsln(i,k) = 0._r8 - loc_conv%activn(i,k) = 0._r8 - loc_conv%dlfn (i,k) = 0._r8 - loc_conv%cmel (i,k) = 0._r8 - - loc_conv%autoim(i,k) = 0._r8 - loc_conv%accsim(i,k) = 0._r8 - loc_conv%difm (i,k) = 0._r8 - loc_conv%cmei (i,k) = 0._r8 - - loc_conv%nuclin(i,k) = 0._r8 - loc_conv%autoin(i,k) = 0._r8 - loc_conv%accsin(i,k) = 0._r8 - loc_conv%hmpin (i,k) = 0._r8 - loc_conv%difn (i,k) = 0._r8 - - loc_conv%trspcm(i,k) = 0._r8 - loc_conv%trspcn(i,k) = 0._r8 - loc_conv%trspim(i,k) = 0._r8 - loc_conv%trspin(i,k) = 0._r8 - end if - end do - end do -! -! compute temperature and moisture changes due to convection. -! - call q1q2_pjr(lchnk , & - dqdt ,dsdt ,qg ,qs ,qu , & - su ,du ,qhat ,shat ,dp , & - mu ,md ,sd ,qd ,qldeg , & - dsubcld ,jt ,maxg ,1 ,lengath , & - cpres ,rl ,msg , & - dlg ,evpg ,cug , & - loc_conv ) -! -! gather back temperature and mixing ratio. -! - - if (zmconv_microp) then - do k = msg + 1,pver - do i = 1,lengath - if (dqdt(i,k)*2._r8*delt+qg(i,k)<0._r8) then - negadq = (dqdt(i,k)+0.5_r8*qg(i,k)/delt)/0.9999_r8 - dqdt(i,k) = dqdt(i,k)-negadq - - do kk=k,jt(i),-1 - if (negadq<0._r8) then - if (rprdg(i,kk)> -negadq*dp(i,k)/dp(i,kk)) then - dsdt(i,k) = dsdt(i,k) + negadq*rl/cpres - if (rprdg(i,kk)>loc_conv%sprd(i,kk)) then - if(rprdg(i,kk)-loc_conv%sprd(i,kk)<-negadq*dp(i,k)/dp(i,kk)) then - dsdt(i,k) = dsdt(i,k) + (negadq+ (rprdg(i,kk)-loc_conv%sprd(i,kk))*dp(i,kk)/dp(i,k))*latice/cpres - loc_conv%sprd(i,kk) = negadq*dp(i,k)/dp(i,kk)+rprdg(i,kk) - end if - else - loc_conv%sprd(i,kk) = loc_conv%sprd(i,kk)+negadq*dp(i,k)/dp(i,kk) - dsdt(i,k) = dsdt(i,k) + negadq*latice/cpres - end if - rprdg(i,kk) = rprdg(i,kk)+negadq*dp(i,k)/dp(i,kk) - negadq = 0._r8 - else - negadq = rprdg(i,kk)*dp(i,kk)/dp(i,k)+negadq - dsdt(i,k) = dsdt(i,k) - rprdg(i,kk)*rl/cpres*dp(i,kk)/dp(i,k) - if (rprdg(i,kk)>loc_conv%sprd(i,kk)) then - dsdt(i,k) = dsdt(i,k) - loc_conv%sprd(i,kk)*latice/cpres*dp(i,kk)/dp(i,k) - loc_conv%sprd(i,kk) = 0._r8 - else - dsdt(i,k) = dsdt(i,k) -rprdg(i,kk)*latice/cpres*dp(i,kk)/dp(i,k) - loc_conv%sprd(i,kk)= loc_conv%sprd(i,kk)- rprdg(i,kk) - end if - rprdg(i,kk) = 0._r8 - end if - - if (dlg(i,kk)>loc_conv%di(i,kk)) then - doliq= .true. - else - doliq= .false. - end if - - if (negadq<0._r8) then - if (doliq) then - if (dlg(i,kk)> -negadq*dp(i,k)/dp(i,kk)) then - dsdt(i,k) = dsdt(i,k) + negadq*rl/cpres - loc_conv%dnl(i,kk) = loc_conv%dnl(i,kk)*(1._r8+negadq*dp(i,k)/dp(i,kk)/dlg(i,kk)) - dlg(i,kk) = dlg(i,kk)+negadq*dp(i,k)/dp(i,kk) - negadq = 0._r8 - else - negadq = negadq + dlg(i,kk)*dp(i,kk)/dp(i,k) - dsdt(i,k) = dsdt(i,k) - dlg(i,kk)*dp(i,kk)/dp(i,k)*rl/cpres - dlg(i,kk) = 0._r8 - loc_conv%dnl(i,kk) = 0._r8 - end if - else - if (loc_conv%di(i,kk)> -negadq*dp(i,k)/dp(i,kk)) then - dsdt(i,k) = dsdt(i,k) + negadq*(rl+latice)/cpres - loc_conv%dni(i,kk) = loc_conv%dni(i,kk)*(1._r8+negadq*dp(i,k)/dp(i,kk)/loc_conv%di(i,kk)) - loc_conv%di(i,kk) = loc_conv%di(i,kk)+negadq*dp(i,k)/dp(i,kk) - negadq = 0._r8 - else - negadq = negadq + loc_conv%di(i,kk)*dp(i,kk)/dp(i,k) - dsdt(i,k) = dsdt(i,k) - loc_conv%di(i,kk)*dp(i,kk)/dp(i,k)*(rl+latice)/cpres - loc_conv%di(i,kk) = 0._r8 - loc_conv%dni(i,kk) = 0._r8 - end if - doliq= .false. - end if - end if - if (negadq<0._r8 .and. doliq ) then - if (dlg(i,kk)> -negadq*dp(i,k)/dp(i,kk)) then - dsdt(i,k) = dsdt(i,k) + negadq*rl/cpres - loc_conv%dnl(i,kk) = loc_conv%dnl(i,kk)*(1._r8+negadq*dp(i,k)/dp(i,kk)/dlg(i,kk)) - dlg(i,kk) = dlg(i,kk)+negadq*dp(i,k)/dp(i,kk) - negadq = 0._r8 - else - negadq = negadq + dlg(i,kk)*dp(i,kk)/dp(i,k) - dsdt(i,k) = dsdt(i,k) - dlg(i,kk)*dp(i,kk)/dp(i,k)*rl/cpres - dlg(i,kk) = 0._r8 - loc_conv%dnl(i,kk) = 0._r8 - end if - end if - - end if - end do - - if (negadq<0._r8) then - dqdt(i,k) = dqdt(i,k) + negadq - end if - - end if - end do - end do - end if - - do k = msg + 1,pver - do i = 1,lengath -! -! q is updated to compute net precip. -! - q(ideep(i),k) = qh(ideep(i),k) + 2._r8*delt*dqdt(i,k) - qtnd(ideep(i),k) = dqdt (i,k) - cme (ideep(i),k) = cmeg (i,k) - rprd(ideep(i),k) = rprdg(i,k) - zdu (ideep(i),k) = du (i,k) - mcon(ideep(i),k) = mc (i,k) - heat(ideep(i),k) = dsdt (i,k)*cpres - dlf (ideep(i),k) = dlg (i,k) - pflx(ideep(i),k) = pflxg(i,k) - ql (ideep(i),k) = qlg (i,k) - end do - end do - - if (zmconv_microp) then - do k = msg + 1,pver - do i = 1,lengath - dif (ideep(i),k) = loc_conv%di (i,k) - dnlf(ideep(i),k) = loc_conv%dnl (i,k) - dnif(ideep(i),k) = loc_conv%dni (i,k) - - conv%qi (ideep(i),k) = loc_conv%qice(i,k) - conv%frz(ideep(i),k) = loc_conv%frz(i,k)*latice/cpres - conv%sprd(ideep(i),k) = loc_conv%sprd(i,k) - conv%wu (ideep(i),k) = loc_conv%wu (i,k) - conv%qliq(ideep(i),k) = loc_conv%qliq (i,k) - conv%qice(ideep(i),k) = loc_conv%qice (i,k) - conv%qrain(ideep(i),k) = loc_conv%qrain (i,k) - conv%qsnow(ideep(i),k) = loc_conv%qsnow (i,k) - conv%qnl(ideep(i),k) = loc_conv%qnl(i,k) - conv%qni(ideep(i),k) = loc_conv%qni(i,k) - conv%qnr(ideep(i),k) = loc_conv%qnr(i,k) - conv%qns(ideep(i),k) = loc_conv%qns(i,k) - - conv%autolm(ideep(i),k) = loc_conv%autolm(i,k) - conv%accrlm(ideep(i),k) = loc_conv%accrlm(i,k) - conv%bergnm(ideep(i),k) = loc_conv%bergnm(i,k) - conv%fhtimm(ideep(i),k) = loc_conv%fhtimm(i,k) - conv%fhtctm(ideep(i),k) = loc_conv%fhtctm(i,k) - conv%fhmlm (ideep(i),k) = loc_conv%fhmlm (i,k) - conv%hmpim (ideep(i),k) = loc_conv%hmpim (i,k) - conv%accslm(ideep(i),k) = loc_conv%accslm(i,k) - conv%dlfm (ideep(i),k) = loc_conv%dlfm (i,k) - - conv%autoln(ideep(i),k) = loc_conv%autoln(i,k) - conv%accrln(ideep(i),k) = loc_conv%accrln(i,k) - conv%bergnn(ideep(i),k) = loc_conv%bergnn(i,k) - conv%fhtimn(ideep(i),k) = loc_conv%fhtimn(i,k) - conv%fhtctn(ideep(i),k) = loc_conv%fhtctn(i,k) - conv%fhmln (ideep(i),k) = loc_conv%fhmln (i,k) - conv%accsln(ideep(i),k) = loc_conv%accsln(i,k) - conv%activn(ideep(i),k) = loc_conv%activn(i,k) - conv%dlfn (ideep(i),k) = loc_conv%dlfn (i,k) - conv%cmel (ideep(i),k) = loc_conv%cmel (i,k) - - conv%autoim(ideep(i),k) = loc_conv%autoim(i,k) - conv%accsim(ideep(i),k) = loc_conv%accsim(i,k) - conv%difm (ideep(i),k) = loc_conv%difm (i,k) - conv%cmei (ideep(i),k) = loc_conv%cmei (i,k) - - conv%nuclin(ideep(i),k) = loc_conv%nuclin(i,k) - conv%autoin(ideep(i),k) = loc_conv%autoin(i,k) - conv%accsin(ideep(i),k) = loc_conv%accsin(i,k) - conv%hmpin (ideep(i),k) = loc_conv%hmpin (i,k) - conv%difn (ideep(i),k) = loc_conv%difn (i,k) - - conv%trspcm(ideep(i),k) = loc_conv%trspcm(i,k) - conv%trspcn(ideep(i),k) = loc_conv%trspcn(i,k) - conv%trspim(ideep(i),k) = loc_conv%trspim(i,k) - conv%trspin(ideep(i),k) = loc_conv%trspin(i,k) - conv%lambdadpcu(ideep(i),k) = loc_conv%lambdadpcu(i,k) - conv%mudpcu(ideep(i),k) = loc_conv%mudpcu(i,k) - - end do - end do - - do k = msg + 1,pver - do i = 1,ncol - - !convert it from units of "kg/kg" to "g/m3" - - if(k.lt.pver) then - conv%qice (i,k) = 0.5_r8*(conv%qice(i,k)+conv%qice(i,k+1)) - conv%qliq (i,k) = 0.5_r8*(conv%qliq(i,k)+conv%qliq(i,k+1)) - conv%qrain (i,k) = 0.5_r8*(conv%qrain(i,k)+conv%qrain(i,k+1)) - conv%qsnow (i,k) = 0.5_r8*(conv%qsnow(i,k)+conv%qsnow(i,k+1)) - conv%qni (i,k) = 0.5_r8*(conv%qni(i,k)+conv%qni(i,k+1)) - conv%qnl (i,k) = 0.5_r8*(conv%qnl(i,k)+conv%qnl(i,k+1)) - conv%qnr (i,k) = 0.5_r8*(conv%qnr(i,k)+conv%qnr(i,k+1)) - conv%qns (i,k) = 0.5_r8*(conv%qns(i,k)+conv%qns(i,k+1)) - conv%wu(i,k) = 0.5_r8*(conv%wu(i,k)+conv%wu(i,k+1)) - end if - - if (t(i,k).gt. 273.15_r8 .and. t(i,k-1).le.273.15_r8) then - conv%qice (i,k-1) = conv%qice (i,k-1) + conv%qice (i,k) - conv%qice (i,k) = 0._r8 - conv%qni (i,k-1) = conv%qni (i,k-1) + conv%qni (i,k) - conv%qni (i,k) = 0._r8 - conv%qsnow (i,k-1) = conv%qsnow (i,k-1) + conv%qsnow (i,k) - conv%qsnow (i,k) = 0._r8 - conv%qns (i,k-1) = conv%qns (i,k-1) + conv%qns (i,k) - conv%qns (i,k) = 0._r8 - end if - - conv%qice (i,k) = conv%qice(i,k) * pap(i,k)/t(i,k)/rgas *1000._r8 - conv%qliq (i,k) = conv%qliq(i,k) * pap(i,k)/t(i,k)/rgas *1000._r8 - conv%qrain (i,k) = conv%qrain(i,k) * pap(i,k)/t(i,k)/rgas *1000._r8 - conv%qsnow (i,k) = conv%qsnow(i,k) * pap(i,k)/t(i,k)/rgas *1000._r8 - conv%qni (i,k) = conv%qni(i,k) * pap(i,k)/t(i,k)/rgas - conv%qnl (i,k) = conv%qnl(i,k) * pap(i,k)/t(i,k)/rgas - conv%qnr (i,k) = conv%qnr(i,k) * pap(i,k)/t(i,k)/rgas - conv%qns (i,k) = conv%qns(i,k) * pap(i,k)/t(i,k)/rgas - end do - end do - end if - -! - do i = 1,lengath - jctop(ideep(i)) = jt(i) - jcbot(ideep(i)) = maxg(i) - pflx(ideep(i),pverp) = pflxg(i,pverp) - end do - - if (zmconv_microp) then - do i = 1,lengath - conv%dcape(ideep(i)) = loc_conv%dcape(i) - end do - end if - -! Compute precip by integrating change in water vapor minus detrained cloud water - do k = pver,msg + 1,-1 - do i = 1,ncol - prec(i) = prec(i) - dpp(i,k)* (q(i,k)-qh(i,k)) - dpp(i,k)*(dlf(i,k)+dif(i,k))*2._r8*delt - end do - end do - -! obtain final precipitation rate in m/s. - do i = 1,ncol - prec(i) = rgrav*max(prec(i),0._r8)/ (2._r8*delt)/1000._r8 - end do - -! Compute reserved liquid (not yet in cldliq) for energy integrals. -! Treat rliq as flux out bottom, to be added back later. - do k = 1, pver - do i = 1, ncol - rliq(i) = rliq(i) + (dlf(i,k)+dif(i,k))*dpp(i,k)/gravit - rice(i) = rice(i) + dif(i,k)*dpp(i,k)/gravit - end do - end do - rliq(:ncol) = rliq(:ncol) /1000._r8 - rice(:ncol) = rice(:ncol) /1000._r8 - - if (zmconv_microp) then - deallocate( & - loc_conv%frz, & - loc_conv%sprd, & - loc_conv%wu, & - loc_conv%qi, & - loc_conv%qliq, & - loc_conv%qice, & - loc_conv%qrain, & - loc_conv%qsnow, & - loc_conv%di, & - loc_conv%dnl, & - loc_conv%dni, & - loc_conv%qnl, & - loc_conv%qni, & - loc_conv%qnr, & - loc_conv%qns, & - loc_conv%qide, & - loc_conv%qncde, & - loc_conv%qnide, & - loc_conv%autolm, & - loc_conv%accrlm, & - loc_conv%bergnm, & - loc_conv%fhtimm, & - loc_conv%fhtctm, & - loc_conv%fhmlm, & - loc_conv%hmpim, & - loc_conv%accslm, & - loc_conv%dlfm, & - loc_conv%cmel, & - loc_conv%autoln, & - loc_conv%accrln, & - loc_conv%bergnn, & - loc_conv%fhtimn, & - loc_conv%fhtctn, & - loc_conv%fhmln, & - loc_conv%accsln, & - loc_conv%activn, & - loc_conv%dlfn, & - loc_conv%autoim, & - loc_conv%accsim, & - loc_conv%difm, & - loc_conv%cmei, & - loc_conv%nuclin, & - loc_conv%autoin, & - loc_conv%accsin, & - loc_conv%hmpin, & - loc_conv%difn, & - loc_conv%trspcm, & - loc_conv%trspcn, & - loc_conv%trspim, & - loc_conv%trspin, & - loc_conv%lambdadpcu, & - loc_conv%mudpcu, & - loc_conv%dcape ) - end if - - return -end subroutine zm_convr - -!=============================================================================== -subroutine zm_conv_evap(ncol,lchnk, & - t,pmid,pdel,q, & - landfrac, & - tend_s, tend_s_snwprd, tend_s_snwevmlt, tend_q, & - prdprec, cldfrc, deltat, & - prec, snow, ntprprd, ntsnprd, flxprec, flxsnow, prdsnow) - - -!----------------------------------------------------------------------- -! Compute tendencies due to evaporation of rain from ZM scheme -!-- -! Compute the total precipitation and snow fluxes at the surface. -! Add in the latent heat of fusion for snow formation and melt, since it not dealt with -! in the Zhang-MacFarlane parameterization. -! Evaporate some of the precip directly into the environment using a Sundqvist type algorithm -!----------------------------------------------------------------------- - - use wv_saturation, only: qsat - use phys_grid, only: get_rlat_all_p - -!------------------------------Arguments-------------------------------- - integer,intent(in) :: ncol, lchnk ! number of columns and chunk index - real(r8),intent(in), dimension(pcols,pver) :: t ! temperature (K) - real(r8),intent(in), dimension(pcols,pver) :: pmid ! midpoint pressure (Pa) - real(r8),intent(in), dimension(pcols,pver) :: pdel ! layer thickness (Pa) - real(r8),intent(in), dimension(pcols,pver) :: q ! water vapor (kg/kg) - real(r8),intent(in), dimension(pcols) :: landfrac - real(r8),intent(inout), dimension(pcols,pver) :: tend_s ! heating rate (J/kg/s) - real(r8),intent(inout), dimension(pcols,pver) :: tend_q ! water vapor tendency (kg/kg/s) - real(r8),intent(out ), dimension(pcols,pver) :: tend_s_snwprd ! Heating rate of snow production - real(r8),intent(out ), dimension(pcols,pver) :: tend_s_snwevmlt ! Heating rate of evap/melting of snow - - - - real(r8), intent(in ) :: prdprec(pcols,pver)! precipitation production (kg/ks/s) - real(r8), intent(in ) :: cldfrc(pcols,pver) ! cloud fraction - real(r8), intent(in ) :: deltat ! time step - - real(r8), intent(inout) :: prec(pcols) ! Convective-scale preciptn rate - real(r8), intent(out) :: snow(pcols) ! Convective-scale snowfall rate - - real(r8), optional, intent(in), allocatable :: prdsnow(:,:) ! snow production (kg/ks/s) - -! -!---------------------------Local storage------------------------------- - - real(r8) :: es (pcols,pver) ! Saturation vapor pressure - real(r8) :: fice (pcols,pver) ! ice fraction in precip production - real(r8) :: fsnow_conv(pcols,pver) ! snow fraction in precip production - real(r8) :: qs (pcols,pver) ! saturation specific humidity - real(r8),intent(out) :: flxprec(pcols,pverp) ! Convective-scale flux of precip at interfaces (kg/m2/s) - real(r8),intent(out) :: flxsnow(pcols,pverp) ! Convective-scale flux of snow at interfaces (kg/m2/s) - real(r8),intent(out) :: ntprprd(pcols,pver) ! net precip production in layer - real(r8),intent(out) :: ntsnprd(pcols,pver) ! net snow production in layer - real(r8) :: work1 ! temp variable (pjr) - real(r8) :: work2 ! temp variable (pjr) - - real(r8) :: evpvint(pcols) ! vertical integral of evaporation - real(r8) :: evpprec(pcols) ! evaporation of precipitation (kg/kg/s) - real(r8) :: evpsnow(pcols) ! evaporation of snowfall (kg/kg/s) - real(r8) :: snowmlt(pcols) ! snow melt tendency in layer - real(r8) :: flxsntm(pcols) ! flux of snow into layer, after melting - - real(r8) :: kemask - real(r8) :: evplimit ! temp variable for evaporation limits - real(r8) :: rlat(pcols) - real(r8) :: dum - real(r8) :: omsm - - integer :: i,k ! longitude,level indices - logical :: old_snow - - -!----------------------------------------------------------------------- - - ! If prdsnow is passed in and allocated, then use it in the calculation, otherwise - ! use the old snow calculation - old_snow=.true. - if (present(prdsnow)) then - if (allocated(prdsnow)) then - old_snow=.false. - end if - end if - -! convert input precip to kg/m2/s - prec(:ncol) = prec(:ncol)*1000._r8 - -! determine saturation vapor pressure - do k = 1,pver - call qsat(t(1:ncol,k), pmid(1:ncol,k), es(1:ncol,k), qs(1:ncol,k), ncol) - end do -! determine ice fraction in rain production (use cloud water parameterization fraction at present) - call cldfrc_fice(ncol, t, fice, fsnow_conv) - -! zero the flux integrals on the top boundary - flxprec(:ncol,1) = 0._r8 - flxsnow(:ncol,1) = 0._r8 - evpvint(:ncol) = 0._r8 - omsm=0.9999_r8 - - do k = 1, pver - do i = 1, ncol - -! Melt snow falling into layer, if necessary. - if( old_snow ) then - if (t(i,k) > tmelt) then - flxsntm(i) = 0._r8 - snowmlt(i) = flxsnow(i,k) * gravit/ pdel(i,k) - else - flxsntm(i) = flxsnow(i,k) - snowmlt(i) = 0._r8 - end if - else - ! make sure melting snow doesn't reduce temperature below threshold - if (t(i,k) > tmelt) then - dum = -latice/cpres*flxsnow(i,k)*gravit/pdel(i,k)*deltat - if (t(i,k) + dum .le. tmelt) then - dum = (t(i,k)-tmelt)*cpres/latice/deltat - dum = dum/(flxsnow(i,k)*gravit/pdel(i,k)) - dum = max(0._r8,dum) - dum = min(1._r8,dum) - else - dum = 1._r8 - end if - dum = dum*omsm - flxsntm(i) = flxsnow(i,k)*(1.0_r8-dum) - snowmlt(i) = dum*flxsnow(i,k)*gravit/ pdel(i,k) - else - flxsntm(i) = flxsnow(i,k) - snowmlt(i) = 0._r8 - end if - end if - -! relative humidity depression must be > 0 for evaporation - evplimit = max(1._r8 - q(i,k)/qs(i,k), 0._r8) - - if (zm_org) then - kemask = ke * (1._r8 - landfrac(i)) + ke_lnd * landfrac(i) - else - kemask = ke - endif - -! total evaporation depends on flux in the top of the layer -! flux prec is the net production above layer minus evaporation into environmet - evpprec(i) = kemask * (1._r8 - cldfrc(i,k)) * evplimit * sqrt(flxprec(i,k)) -!********************************************************** -!! evpprec(i) = 0. ! turn off evaporation for now -!********************************************************** - -! Don't let evaporation supersaturate layer (approx). Layer may already be saturated. -! Currently does not include heating/cooling change to qs - evplimit = max(0._r8, (qs(i,k)-q(i,k)) / deltat) - -! Don't evaporate more than is falling into the layer - do not evaporate rain formed -! in this layer but if precip production is negative, remove from the available precip -! Negative precip production occurs because of evaporation in downdrafts. -!!$ evplimit = flxprec(i,k) * gravit / pdel(i,k) + min(prdprec(i,k), 0.) - evplimit = min(evplimit, flxprec(i,k) * gravit / pdel(i,k)) - -! Total evaporation cannot exceed input precipitation - evplimit = min(evplimit, (prec(i) - evpvint(i)) * gravit / pdel(i,k)) - - evpprec(i) = min(evplimit, evpprec(i)) - if( .not.old_snow ) then - evpprec(i) = max(0._r8, evpprec(i)) - evpprec(i) = evpprec(i)*omsm - end if - - -! evaporation of snow depends on snow fraction of total precipitation in the top after melting - if (flxprec(i,k) > 0._r8) then -! evpsnow(i) = evpprec(i) * flxsntm(i) / flxprec(i,k) -! prevent roundoff problems - work1 = min(max(0._r8,flxsntm(i)/flxprec(i,k)),1._r8) - evpsnow(i) = evpprec(i) * work1 - else - evpsnow(i) = 0._r8 - end if - -! vertically integrated evaporation - evpvint(i) = evpvint(i) + evpprec(i) * pdel(i,k)/gravit - -! net precip production is production - evaporation - ntprprd(i,k) = prdprec(i,k) - evpprec(i) -! net snow production is precip production * ice fraction - evaporation - melting -!pjrworks ntsnprd(i,k) = prdprec(i,k)*fice(i,k) - evpsnow(i) - snowmlt(i) -!pjrwrks2 ntsnprd(i,k) = prdprec(i,k)*fsnow_conv(i,k) - evpsnow(i) - snowmlt(i) -! the small amount added to flxprec in the work1 expression has been increased from -! 1e-36 to 8.64e-11 (1e-5 mm/day). This causes the temperature based partitioning -! scheme to be used for small flxprec amounts. This is to address error growth problems. - - if( old_snow ) then - if (flxprec(i,k).gt.0._r8) then - work1 = min(max(0._r8,flxsnow(i,k)/flxprec(i,k)),1._r8) - else - work1 = 0._r8 - endif - - work2 = max(fsnow_conv(i,k), work1) - if (snowmlt(i).gt.0._r8) work2 = 0._r8 -! work2 = fsnow_conv(i,k) - ntsnprd(i,k) = prdprec(i,k)*work2 - evpsnow(i) - snowmlt(i) - tend_s_snwprd (i,k) = prdprec(i,k)*work2*latice - tend_s_snwevmlt(i,k) = - ( evpsnow(i) + snowmlt(i) )*latice - else - ntsnprd(i,k) = prdsnow(i,k) - min(flxsnow(i,k)*gravit/pdel(i,k), evpsnow(i)+snowmlt(i)) - tend_s_snwprd (i,k) = prdsnow(i,k)*latice - tend_s_snwevmlt(i,k) = -min(flxsnow(i,k)*gravit/pdel(i,k), evpsnow(i)+snowmlt(i) )*latice - end if - -! precipitation fluxes - flxprec(i,k+1) = flxprec(i,k) + ntprprd(i,k) * pdel(i,k)/gravit - flxsnow(i,k+1) = flxsnow(i,k) + ntsnprd(i,k) * pdel(i,k)/gravit - -! protect against rounding error - flxprec(i,k+1) = max(flxprec(i,k+1), 0._r8) - flxsnow(i,k+1) = max(flxsnow(i,k+1), 0._r8) -! more protection (pjr) -! flxsnow(i,k+1) = min(flxsnow(i,k+1), flxprec(i,k+1)) - -! heating (cooling) and moistening due to evaporation -! - latent heat of vaporization for precip production has already been accounted for -! - snow is contained in prec - if( old_snow ) then - tend_s(i,k) =-evpprec(i)*latvap + ntsnprd(i,k)*latice - else - tend_s(i,k) =-evpprec(i)*latvap + tend_s_snwevmlt(i,k) - end if - tend_q(i,k) = evpprec(i) - end do - end do - -! set output precipitation rates (m/s) - prec(:ncol) = flxprec(:ncol,pver+1) / 1000._r8 - snow(:ncol) = flxsnow(:ncol,pver+1) / 1000._r8 - -!********************************************************** -!!$ tend_s(:ncol,:) = 0. ! turn heating off -!********************************************************** - - end subroutine zm_conv_evap - - - -subroutine convtran(lchnk , & - doconvtran,q ,ncnst ,mu ,md , & - du ,eu ,ed ,dp ,dsubcld , & - jt ,mx ,ideep ,il1g ,il2g , & - nstep ,fracis ,dqdt ,dpdry ,dt) -!----------------------------------------------------------------------- -! -! Purpose: -! Convective transport of trace species -! -! Mixing ratios may be with respect to either dry or moist air -! -! Method: -! -! -! -! Author: P. Rasch -! -!----------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: cnst_get_type_byind - use ppgrid - - implicit none -!----------------------------------------------------------------------- -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncnst ! number of tracers to transport - logical, intent(in) :: doconvtran(ncnst) ! flag for doing convective transport - real(r8), intent(in) :: q(pcols,pver,ncnst) ! Tracer array including moisture - real(r8), intent(in) :: mu(pcols,pver) ! Mass flux up - real(r8), intent(in) :: md(pcols,pver) ! Mass flux down - real(r8), intent(in) :: du(pcols,pver) ! Mass detraining from updraft - real(r8), intent(in) :: eu(pcols,pver) ! Mass entraining from updraft - real(r8), intent(in) :: ed(pcols,pver) ! Mass entraining from downdraft - real(r8), intent(in) :: dp(pcols,pver) ! Delta pressure between interfaces - real(r8), intent(in) :: dsubcld(pcols) ! Delta pressure from cloud base to sfc - real(r8), intent(in) :: fracis(pcols,pver,ncnst) ! fraction of tracer that is insoluble - - integer, intent(in) :: jt(pcols) ! Index of cloud top for each column - integer, intent(in) :: mx(pcols) ! Index of cloud top for each column - integer, intent(in) :: ideep(pcols) ! Gathering array - integer, intent(in) :: il1g ! Gathered min lon indices over which to operate - integer, intent(in) :: il2g ! Gathered max lon indices over which to operate - integer, intent(in) :: nstep ! Time step index - - real(r8), intent(in) :: dpdry(pcols,pver) ! Delta pressure between interfaces - - real(r8), intent(in) :: dt ! 2 delta t (model time increment) - -! input/output - - real(r8), intent(out) :: dqdt(pcols,pver,ncnst) ! Tracer tendency array - -!--------------------------Local Variables------------------------------ - - integer i ! Work index - integer k ! Work index - integer kbm ! Highest altitude index of cloud base - integer kk ! Work index - integer kkp1 ! Work index - integer km1 ! Work index - integer kp1 ! Work index - integer ktm ! Highest altitude index of cloud top - integer m ! Work index - - real(r8) cabv ! Mix ratio of constituent above - real(r8) cbel ! Mix ratio of constituent below - real(r8) cdifr ! Normalized diff between cabv and cbel - real(r8) chat(pcols,pver) ! Mix ratio in env at interfaces - real(r8) cond(pcols,pver) ! Mix ratio in downdraft at interfaces - real(r8) const(pcols,pver) ! Gathered tracer array - real(r8) fisg(pcols,pver) ! gathered insoluble fraction of tracer - real(r8) conu(pcols,pver) ! Mix ratio in updraft at interfaces - real(r8) dcondt(pcols,pver) ! Gathered tend array - real(r8) small ! A small number - real(r8) mbsth ! Threshold for mass fluxes - real(r8) mupdudp ! A work variable - real(r8) minc ! A work variable - real(r8) maxc ! A work variable - real(r8) fluxin ! A work variable - real(r8) fluxout ! A work variable - real(r8) netflux ! A work variable - - real(r8) dutmp(pcols,pver) ! Mass detraining from updraft - real(r8) eutmp(pcols,pver) ! Mass entraining from updraft - real(r8) edtmp(pcols,pver) ! Mass entraining from downdraft - real(r8) dptmp(pcols,pver) ! Delta pressure between interfaces - real(r8) total(pcols) - real(r8) negadt,qtmp - -!----------------------------------------------------------------------- -! - small = 1.e-36_r8 -! mbsth is the threshold below which we treat the mass fluxes as zero (in mb/s) - mbsth = 1.e-15_r8 - -! Find the highest level top and bottom levels of convection - ktm = pver - kbm = pver - do i = il1g, il2g - ktm = min(ktm,jt(i)) - kbm = min(kbm,mx(i)) - end do - -! Loop ever each constituent - do m = 2, ncnst - if (doconvtran(m)) then - - if (cnst_get_type_byind(m).eq.'dry') then - do k = 1,pver - do i =il1g,il2g - dptmp(i,k) = dpdry(i,k) - dutmp(i,k) = du(i,k)*dp(i,k)/dpdry(i,k) - eutmp(i,k) = eu(i,k)*dp(i,k)/dpdry(i,k) - edtmp(i,k) = ed(i,k)*dp(i,k)/dpdry(i,k) - end do - end do - else - do k = 1,pver - do i =il1g,il2g - dptmp(i,k) = dp(i,k) - dutmp(i,k) = du(i,k) - eutmp(i,k) = eu(i,k) - edtmp(i,k) = ed(i,k) - end do - end do - endif -! dptmp = dp - -! Gather up the constituent and set tend to zero - do k = 1,pver - do i =il1g,il2g - const(i,k) = q(ideep(i),k,m) - fisg(i,k) = fracis(ideep(i),k,m) - end do - end do - -! From now on work only with gathered data - -! Interpolate environment tracer values to interfaces - do k = 1,pver - km1 = max(1,k-1) - do i = il1g, il2g - minc = min(const(i,km1),const(i,k)) - maxc = max(const(i,km1),const(i,k)) - if (minc < 0) then - cdifr = 0._r8 - else - cdifr = abs(const(i,k)-const(i,km1))/max(maxc,small) - endif - -! If the two layers differ significantly use a geometric averaging -! procedure - if (cdifr > 1.E-6_r8) then - cabv = max(const(i,km1),maxc*1.e-12_r8) - cbel = max(const(i,k),maxc*1.e-12_r8) - chat(i,k) = log(cabv/cbel)/(cabv-cbel)*cabv*cbel - - else ! Small diff, so just arithmetic mean - chat(i,k) = 0.5_r8* (const(i,k)+const(i,km1)) - end if - -! Provisional up and down draft values - conu(i,k) = chat(i,k) - cond(i,k) = chat(i,k) - -! provisional tends - dcondt(i,k) = 0._r8 - - end do - end do - -! Do levels adjacent to top and bottom - k = 2 - km1 = 1 - kk = pver - do i = il1g,il2g - mupdudp = mu(i,kk) + dutmp(i,kk)*dptmp(i,kk) - if (mupdudp > mbsth) then - conu(i,kk) = (+eutmp(i,kk)*fisg(i,kk)*const(i,kk)*dptmp(i,kk))/mupdudp - endif - if (md(i,k) < -mbsth) then - cond(i,k) = (-edtmp(i,km1)*fisg(i,km1)*const(i,km1)*dptmp(i,km1))/md(i,k) - endif - end do - -! Updraft from bottom to top - do kk = pver-1,1,-1 - kkp1 = min(pver,kk+1) - do i = il1g,il2g - mupdudp = mu(i,kk) + dutmp(i,kk)*dptmp(i,kk) - if (mupdudp > mbsth) then - conu(i,kk) = ( mu(i,kkp1)*conu(i,kkp1)+eutmp(i,kk)*fisg(i,kk)* & - const(i,kk)*dptmp(i,kk) )/mupdudp - endif - end do - end do - -! Downdraft from top to bottom - do k = 3,pver - km1 = max(1,k-1) - do i = il1g,il2g - if (md(i,k) < -mbsth) then - cond(i,k) = ( md(i,km1)*cond(i,km1)-edtmp(i,km1)*fisg(i,km1)*const(i,km1) & - *dptmp(i,km1) )/md(i,k) - endif - end do - end do - - - do k = ktm,pver - km1 = max(1,k-1) - kp1 = min(pver,k+1) - do i = il1g,il2g - -! version 1 hard to check for roundoff errors -! dcondt(i,k) = -! $ +(+mu(i,kp1)* (conu(i,kp1)-chat(i,kp1)) -! $ -mu(i,k)* (conu(i,k)-chat(i,k)) -! $ +md(i,kp1)* (cond(i,kp1)-chat(i,kp1)) -! $ -md(i,k)* (cond(i,k)-chat(i,k)) -! $ )/dp(i,k) - -! version 2 hard to limit fluxes -! fluxin = mu(i,kp1)*conu(i,kp1) + mu(i,k)*chat(i,k) -! $ -(md(i,k) *cond(i,k) + md(i,kp1)*chat(i,kp1)) -! fluxout = mu(i,k)*conu(i,k) + mu(i,kp1)*chat(i,kp1) -! $ -(md(i,kp1)*cond(i,kp1) + md(i,k)*chat(i,k)) - -! version 3 limit fluxes outside convection to mass in appropriate layer -! these limiters are probably only safe for positive definite quantitities -! it assumes that mu and md already satify a courant number limit of 1 - fluxin = mu(i,kp1)*conu(i,kp1)+ mu(i,k)*min(chat(i,k),const(i,km1)) & - -(md(i,k) *cond(i,k) + md(i,kp1)*min(chat(i,kp1),const(i,kp1))) - fluxout = mu(i,k)*conu(i,k) + mu(i,kp1)*min(chat(i,kp1),const(i,k)) & - -(md(i,kp1)*cond(i,kp1) + md(i,k)*min(chat(i,k),const(i,k))) - - netflux = fluxin - fluxout - if (abs(netflux) < max(fluxin,fluxout)*1.e-12_r8) then - netflux = 0._r8 - endif - dcondt(i,k) = netflux/dptmp(i,k) - end do - end do -! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -! - do k = kbm,pver - km1 = max(1,k-1) - do i = il1g,il2g - if (k == mx(i)) then - -! version 1 -! dcondt(i,k) = (1./dsubcld(i))* -! $ (-mu(i,k)*(conu(i,k)-chat(i,k)) -! $ -md(i,k)*(cond(i,k)-chat(i,k)) -! $ ) - -! version 2 -! fluxin = mu(i,k)*chat(i,k) - md(i,k)*cond(i,k) -! fluxout = mu(i,k)*conu(i,k) - md(i,k)*chat(i,k) -! version 3 - fluxin = mu(i,k)*min(chat(i,k),const(i,km1)) - md(i,k)*cond(i,k) - fluxout = mu(i,k)*conu(i,k) - md(i,k)*min(chat(i,k),const(i,k)) - - netflux = fluxin - fluxout - if (abs(netflux) < max(fluxin,fluxout)*1.e-12_r8) then - netflux = 0._r8 - endif -! dcondt(i,k) = netflux/dsubcld(i) - dcondt(i,k) = netflux/dptmp(i,k) - else if (k > mx(i)) then -! dcondt(i,k) = dcondt(i,k-1) - dcondt(i,k) = 0._r8 - end if - end do - end do - - if (zmconv_microp) then - do i = il1g,il2g - do k = jt(i),mx(i) - if (dcondt(i,k)*dt+const(i,k)<0._r8) then - negadt = dcondt(i,k)+const(i,k)/dt - dcondt(i,k) = -const(i,k)/dt - do kk= k+1, mx(i) - if (negadt<0._r8 .and. dcondt(i,kk)*dt+const(i,kk)>0._r8 ) then - qtmp = dcondt(i,kk)+negadt*dptmp(i,k)/dptmp(i,kk) - if (qtmp*dt+const(i,kk)>0._r8) then - dcondt(i,kk)= qtmp - negadt=0._r8 - else - negadt= negadt+(const(i,kk)/dt+dcondt(i,kk))*dptmp(i,kk)/dptmp(i,k) - dcondt(i,kk)= -const(i,kk)/dt - end if - - end if - end do - do kk= k-1, jt(i), -1 - if (negadt<0._r8 .and. dcondt(i,kk)*dt+const(i,kk)>0._r8 ) then - qtmp = dcondt(i,kk)+negadt*dptmp(i,k)/dptmp(i,kk) - if (qtmp*dt+const(i,kk)>0._r8) then - dcondt(i,kk)= qtmp - negadt=0._r8 - else - negadt= negadt+(const(i,kk)/dt+dcondt(i,kk))*dptmp(i,kk)/dptmp(i,k) - dcondt(i,kk)= -const(i,kk)/dt - end if - end if - end do - - if (negadt<0._r8) then - dcondt(i,k) = dcondt(i,k) + negadt - end if - end if - end do - end do - end if - - -! Initialize to zero everywhere, then scatter tendency back to full array - dqdt(:,:,m) = 0._r8 - do k = 1,pver - kp1 = min(pver,k+1) - do i = il1g,il2g - dqdt(ideep(i),k,m) = dcondt(i,k) - end do - end do - - end if ! for doconvtran - - end do - - return -end subroutine convtran - -!========================================================================================= - -subroutine momtran(lchnk, ncol, & - domomtran,q ,ncnst ,mu ,md , & - du ,eu ,ed ,dp ,dsubcld , & - jt ,mx ,ideep ,il1g ,il2g , & - nstep ,dqdt ,pguall ,pgdall, icwu, icwd, dt, seten ) -!----------------------------------------------------------------------- -! -! Purpose: -! Convective transport of momentum -! -! Mixing ratios may be with respect to either dry or moist air -! -! Method: -! Based on the convtran subroutine by P. Rasch -! -! -! Author: J. Richter and P. Rasch -! -!----------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: cnst_get_type_byind - use ppgrid - - implicit none -!----------------------------------------------------------------------- -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: ncnst ! number of tracers to transport - logical, intent(in) :: domomtran(ncnst) ! flag for doing convective transport - real(r8), intent(in) :: q(pcols,pver,ncnst) ! Wind array - real(r8), intent(in) :: mu(pcols,pver) ! Mass flux up - real(r8), intent(in) :: md(pcols,pver) ! Mass flux down - real(r8), intent(in) :: du(pcols,pver) ! Mass detraining from updraft - real(r8), intent(in) :: eu(pcols,pver) ! Mass entraining from updraft - real(r8), intent(in) :: ed(pcols,pver) ! Mass entraining from downdraft - real(r8), intent(in) :: dp(pcols,pver) ! Delta pressure between interfaces - real(r8), intent(in) :: dsubcld(pcols) ! Delta pressure from cloud base to sfc - real(r8), intent(in) :: dt ! time step in seconds : 2*delta_t - - integer, intent(in) :: jt(pcols) ! Index of cloud top for each column - integer, intent(in) :: mx(pcols) ! Index of cloud top for each column - integer, intent(in) :: ideep(pcols) ! Gathering array - integer, intent(in) :: il1g ! Gathered min lon indices over which to operate - integer, intent(in) :: il2g ! Gathered max lon indices over which to operate - integer, intent(in) :: nstep ! Time step index - - - -! input/output - - real(r8), intent(out) :: dqdt(pcols,pver,ncnst) ! Tracer tendency array - -!--------------------------Local Variables------------------------------ - - integer i ! Work index - integer k ! Work index - integer kbm ! Highest altitude index of cloud base - integer kk ! Work index - integer kkp1 ! Work index - integer kkm1 ! Work index - integer km1 ! Work index - integer kp1 ! Work index - integer ktm ! Highest altitude index of cloud top - integer m ! Work index - integer ii ! Work index - - real(r8) cabv ! Mix ratio of constituent above - real(r8) cbel ! Mix ratio of constituent below - real(r8) cdifr ! Normalized diff between cabv and cbel - real(r8) chat(pcols,pver) ! Mix ratio in env at interfaces - real(r8) cond(pcols,pver) ! Mix ratio in downdraft at interfaces - real(r8) const(pcols,pver) ! Gathered wind array - real(r8) conu(pcols,pver) ! Mix ratio in updraft at interfaces - real(r8) dcondt(pcols,pver) ! Gathered tend array - real(r8) mbsth ! Threshold for mass fluxes - real(r8) mupdudp ! A work variable - real(r8) minc ! A work variable - real(r8) maxc ! A work variable - real(r8) fluxin ! A work variable - real(r8) fluxout ! A work variable - real(r8) netflux ! A work variable - - real(r8) sum ! sum - real(r8) sum2 ! sum2 - - real(r8) mududp(pcols,pver) ! working variable - real(r8) mddudp(pcols,pver) ! working variable - - real(r8) pgu(pcols,pver) ! Pressure gradient term for updraft - real(r8) pgd(pcols,pver) ! Pressure gradient term for downdraft - - real(r8),intent(out) :: pguall(pcols,pver,ncnst) ! Apparent force from updraft PG - real(r8),intent(out) :: pgdall(pcols,pver,ncnst) ! Apparent force from downdraft PG - - real(r8),intent(out) :: icwu(pcols,pver,ncnst) ! In-cloud winds in updraft - real(r8),intent(out) :: icwd(pcols,pver,ncnst) ! In-cloud winds in downdraft - - real(r8),intent(out) :: seten(pcols,pver) ! Dry static energy tendency - real(r8) gseten(pcols,pver) ! Gathered dry static energy tendency - - real(r8) mflux(pcols,pverp,ncnst) ! Gathered momentum flux - - real(r8) wind0(pcols,pver,ncnst) ! gathered wind before time step - real(r8) windf(pcols,pver,ncnst) ! gathered wind after time step - real(r8) fkeb, fket, ketend_cons, ketend, utop, ubot, vtop, vbot, gset2 - - -!----------------------------------------------------------------------- -! - -! Initialize outgoing fields - pguall(:,:,:) = 0.0_r8 - pgdall(:,:,:) = 0.0_r8 -! Initialize in-cloud winds to environmental wind - icwu(:ncol,:,:) = q(:ncol,:,:) - icwd(:ncol,:,:) = q(:ncol,:,:) - -! Initialize momentum flux and final winds - mflux(:,:,:) = 0.0_r8 - wind0(:,:,:) = 0.0_r8 - windf(:,:,:) = 0.0_r8 - -! Initialize dry static energy - - seten(:,:) = 0.0_r8 - gseten(:,:) = 0.0_r8 - -! mbsth is the threshold below which we treat the mass fluxes as zero (in mb/s) - mbsth = 1.e-15_r8 - -! Find the highest level top and bottom levels of convection - ktm = pver - kbm = pver - do i = il1g, il2g - ktm = min(ktm,jt(i)) - kbm = min(kbm,mx(i)) - end do - -! Loop ever each wind component - do m = 1, ncnst !start at m = 1 to transport momentum - if (domomtran(m)) then - -! Gather up the winds and set tend to zero - do k = 1,pver - do i =il1g,il2g - const(i,k) = q(ideep(i),k,m) - wind0(i,k,m) = const(i,k) - end do - end do - - -! From now on work only with gathered data - -! Interpolate winds to interfaces - - do k = 1,pver - km1 = max(1,k-1) - do i = il1g, il2g - - ! use arithmetic mean - chat(i,k) = 0.5_r8* (const(i,k)+const(i,km1)) - -! Provisional up and down draft values - conu(i,k) = chat(i,k) - cond(i,k) = chat(i,k) - -! provisional tends - dcondt(i,k) = 0._r8 - - end do - end do - - -! -! Pressure Perturbation Term -! - - !Top boundary: assume mu is zero - - k=1 - pgu(:il2g,k) = 0.0_r8 - pgd(:il2g,k) = 0.0_r8 - - do k=2,pver-1 - km1 = max(1,k-1) - kp1 = min(pver,k+1) - do i = il1g,il2g - - !interior points - - mududp(i,k) = ( mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) & - + mu(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k)) - - pgu(i,k) = - momcu * 0.5_r8 * mududp(i,k) - - - mddudp(i,k) = ( md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) & - + md(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k)) - - pgd(i,k) = - momcd * 0.5_r8 * mddudp(i,k) - - - end do - end do - - ! bottom boundary - k = pver - km1 = max(1,k-1) - do i=il1g,il2g - - mududp(i,k) = mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) - pgu(i,k) = - momcu * mududp(i,k) - - mddudp(i,k) = md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) - - pgd(i,k) = - momcd * mddudp(i,k) - - end do - - -! -! In-cloud velocity calculations -! - -! Do levels adjacent to top and bottom - k = 2 - km1 = 1 - kk = pver - kkm1 = max(1,kk-1) - do i = il1g,il2g - mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk) - if (mupdudp > mbsth) then - - conu(i,kk) = (+eu(i,kk)*const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp - endif - if (md(i,k) < -mbsth) then - cond(i,k) = (-ed(i,km1)*const(i,km1)*dp(i,km1))-pgd(i,km1)*dp(i,km1)/md(i,k) - endif - - - end do - - - -! Updraft from bottom to top - do kk = pver-1,1,-1 - kkm1 = max(1,kk-1) - kkp1 = min(pver,kk+1) - do i = il1g,il2g - mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk) - if (mupdudp > mbsth) then - - conu(i,kk) = ( mu(i,kkp1)*conu(i,kkp1)+eu(i,kk)* & - const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp - endif - end do - - end do - - -! Downdraft from top to bottom - do k = 3,pver - km1 = max(1,k-1) - do i = il1g,il2g - if (md(i,k) < -mbsth) then - - cond(i,k) = ( md(i,km1)*cond(i,km1)-ed(i,km1)*const(i,km1) & - *dp(i,km1)-pgd(i,km1)*dp(i,km1) )/md(i,k) - - endif - end do - end do - - - sum = 0._r8 - sum2 = 0._r8 - - - do k = ktm,pver - km1 = max(1,k-1) - kp1 = min(pver,k+1) - do i = il1g,il2g - ii = ideep(i) - -! version 1 hard to check for roundoff errors - dcondt(i,k) = & - +(mu(i,kp1)* (conu(i,kp1)-chat(i,kp1)) & - -mu(i,k)* (conu(i,k)-chat(i,k)) & - +md(i,kp1)* (cond(i,kp1)-chat(i,kp1)) & - -md(i,k)* (cond(i,k)-chat(i,k)) & - )/dp(i,k) - - end do - end do - - ! dcont for bottom layer - ! - do k = kbm,pver - km1 = max(1,k-1) - do i = il1g,il2g - if (k == mx(i)) then - - ! version 1 - dcondt(i,k) = (1._r8/dp(i,k))* & - (-mu(i,k)*(conu(i,k)-chat(i,k)) & - -md(i,k)*(cond(i,k)-chat(i,k)) & - ) - end if - end do - end do - -! Initialize to zero everywhere, then scatter tendency back to full array - dqdt(:,:,m) = 0._r8 - - do k = 1,pver - do i = il1g,il2g - ii = ideep(i) - dqdt(ii,k,m) = dcondt(i,k) - ! Output apparent force on the mean flow from pressure gradient - pguall(ii,k,m) = -pgu(i,k) - pgdall(ii,k,m) = -pgd(i,k) - icwu(ii,k,m) = conu(i,k) - icwd(ii,k,m) = cond(i,k) - end do - end do - - ! Calculate momentum flux in units of mb*m/s2 - - do k = ktm,pver - do i = il1g,il2g - ii = ideep(i) - mflux(i,k,m) = & - -mu(i,k)* (conu(i,k)-chat(i,k)) & - -md(i,k)* (cond(i,k)-chat(i,k)) - end do - end do - - - ! Calculate winds at the end of the time step - - do k = ktm,pver - do i = il1g,il2g - ii = ideep(i) - km1 = max(1,k-1) - kp1 = k+1 - windf(i,k,m) = const(i,k) - (mflux(i,kp1,m) - mflux(i,k,m)) * dt /dp(i,k) - - end do - end do - - end if ! for domomtran - end do - - ! Need to add an energy fix to account for the dissipation of kinetic energy - ! Formulation follows from Boville and Bretherton (2003) - ! formulation by PJR - - do k = ktm,pver - km1 = max(1,k-1) - kp1 = min(pver,k+1) - do i = il1g,il2g - - ii = ideep(i) - - ! calculate the KE fluxes at top and bot of layer - ! based on a discrete approximation to b&b eq(35) F_KE = u*F_u + v*F_v at interface - utop = (wind0(i,k,1)+wind0(i,km1,1))/2._r8 - vtop = (wind0(i,k,2)+wind0(i,km1,2))/2._r8 - ubot = (wind0(i,kp1,1)+wind0(i,k,1))/2._r8 - vbot = (wind0(i,kp1,2)+wind0(i,k,2))/2._r8 - fket = utop*mflux(i,k,1) + vtop*mflux(i,k,2) ! top of layer - fkeb = ubot*mflux(i,k+1,1) + vbot*mflux(i,k+1,2) ! bot of layer - - ! divergence of these fluxes should give a conservative redistribution of KE - ketend_cons = (fket-fkeb)/dp(i,k) - - ! tendency in kinetic energy resulting from the momentum transport - ketend = ((windf(i,k,1)**2 + windf(i,k,2)**2) - (wind0(i,k,1)**2 + wind0(i,k,2)**2))*0.5_r8/dt - - ! the difference should be the dissipation - gset2 = ketend_cons - ketend - gseten(i,k) = gset2 - - end do - - end do - - ! Scatter dry static energy to full array - do k = 1,pver - do i = il1g,il2g - ii = ideep(i) - seten(ii,k) = gseten(i,k) - - end do - end do - - return -end subroutine momtran - -!========================================================================================= - -subroutine buoyan(lchnk ,ncol , & - q ,t ,p ,z ,pf , & - tp ,qstp ,tl ,rl ,cape , & - pblt ,lcl ,lel ,lon ,mx , & - rd ,grav ,cp ,msg , & - tpert ) -!----------------------------------------------------------------------- -! -! Purpose: -! -! -! Method: -! -! -! -! Author: -! This is contributed code not fully standardized by the CCM core group. -! The documentation has been enhanced to the degree that we are able. -! Reviewed: P. Rasch, April 1996 -! -!----------------------------------------------------------------------- - implicit none -!----------------------------------------------------------------------- -! -! input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - - real(r8), intent(in) :: q(pcols,pver) ! spec. humidity - real(r8), intent(in) :: t(pcols,pver) ! temperature - real(r8), intent(in) :: p(pcols,pver) ! pressure - real(r8), intent(in) :: z(pcols,pver) ! height - real(r8), intent(in) :: pf(pcols,pver+1) ! pressure at interfaces - real(r8), intent(in) :: pblt(pcols) ! index of pbl depth - real(r8), intent(in) :: tpert(pcols) ! perturbation temperature by pbl processes - -! -! output arguments -! - real(r8), intent(out) :: tp(pcols,pver) ! parcel temperature - real(r8), intent(out) :: qstp(pcols,pver) ! saturation mixing ratio of parcel - real(r8), intent(out) :: tl(pcols) ! parcel temperature at lcl - real(r8), intent(out) :: cape(pcols) ! convective aval. pot. energy. - integer lcl(pcols) ! - integer lel(pcols) ! - integer lon(pcols) ! level of onset of deep convection - integer mx(pcols) ! level of max moist static energy -! -!--------------------------Local Variables------------------------------ -! - real(r8) capeten(pcols,num_cin) ! provisional value of cape - real(r8) tv(pcols,pver) ! - real(r8) tpv(pcols,pver) ! - real(r8) buoy(pcols,pver) - - real(r8) a1(pcols) - real(r8) a2(pcols) - real(r8) estp(pcols) - real(r8) pl(pcols) - real(r8) plexp(pcols) - real(r8) hmax(pcols) - real(r8) hmn(pcols) - real(r8) y(pcols) - - logical plge600(pcols) - integer knt(pcols) - integer lelten(pcols,num_cin) - - real(r8) cp - real(r8) e - real(r8) grav - - integer i - integer k - integer msg - integer n - - real(r8) rd - real(r8) rl -! -!----------------------------------------------------------------------- -! - do n = 1,num_cin - do i = 1,ncol - lelten(i,n) = pver - capeten(i,n) = 0._r8 - end do - end do -! - do i = 1,ncol - lon(i) = pver - knt(i) = 0 - lel(i) = pver - mx(i) = lon(i) - cape(i) = 0._r8 - hmax(i) = 0._r8 - end do - - tp(:ncol,:) = t(:ncol,:) - qstp(:ncol,:) = q(:ncol,:) - -!!! RBN - Initialize tv and buoy for output. -!!! tv=tv : tpv=tpv : qstp=q : buoy=0. - tv(:ncol,:) = t(:ncol,:) *(1._r8+1.608_r8*q(:ncol,:))/ (1._r8+q(:ncol,:)) - tpv(:ncol,:) = tv(:ncol,:) - buoy(:ncol,:) = 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 = pver,msg + 1,-1 - do i = 1,ncol - hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k) - if (k >= nint(pblt(i)) .and. k <= lon(i) .and. hmn(i) > hmax(i)) then - hmax(i) = hmn(i) - mx(i) = k - end if - end do - end do - -! - do i = 1,ncol - lcl(i) = mx(i) - e = p(i,mx(i))*q(i,mx(i))/ (eps1+q(i,mx(i))) - tl(i) = 2840._r8/ (3.5_r8*log(t(i,mx(i)))-log(e)-4.805_r8) + 55._r8 - if (tl(i) < t(i,mx(i))) then - plexp(i) = (1._r8/ (0.2854_r8* (1._r8-0.28_r8*q(i,mx(i))))) - pl(i) = p(i,mx(i))* (tl(i)/t(i,mx(i)))**plexp(i) - else - tl(i) = t(i,mx(i)) - pl(i) = p(i,mx(i)) - end if - end do - -! -! calculate lifting condensation level (lcl). -! - do k = pver,msg + 2,-1 - do i = 1,ncol - if (k <= mx(i) .and. (p(i,k) > pl(i) .and. p(i,k-1) <= pl(i))) then - lcl(i) = k - 1 - end if - end do - end do -! -! 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,ncol - plge600(i) = pl(i).ge.600._r8 - end do -! -! initialize parcel properties in sub-cloud layer below lcl. -! - do k = pver,msg + 1,-1 - do i=1,ncol - if (k > lcl(i) .and. k <= mx(i) .and. plge600(i)) then - tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k)) - qstp(i,k) = q(i,mx(i)) - tp(i,k) = t(i,mx(i))* (p(i,k)/p(i,mx(i)))**(0.2854_r8* (1._r8-0.28_r8*q(i,mx(i)))) -! -! buoyancy is increased by 0.5 k as in tiedtke -! -!-jjh tpv (i,k)=tp(i,k)*(1.+1.608*q(i,mx(i)))/ -!-jjh 1 (1.+q(i,mx(i))) - tpv(i,k) = (tp(i,k)+tpert(i))*(1._r8+1.608_r8*q(i,mx(i)))/ (1._r8+q(i,mx(i))) - buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add - end if - end do - end do - -! -! define parcel properties at lcl (i.e. level immediately above pl). -! - do k = pver,msg + 1,-1 - do i=1,ncol - if (k == lcl(i) .and. plge600(i)) then - tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k)) - qstp(i,k) = q(i,mx(i)) - tp(i,k) = tl(i)* (p(i,k)/pl(i))**(0.2854_r8* (1._r8-0.28_r8*qstp(i,k))) -! estp(i) =exp(21.656_r8 - 5418._r8/tp(i,k)) -! use of different formulas for es has about 1 g/kg difference -! in qs at t= 300k, and 0.02 g/kg at t=263k, with the formula -! above giving larger qs. - call qsat_hPa(tp(i,k), p(i,k), estp(i), qstp(i,k)) - a1(i) = cp / rl + qstp(i,k) * (1._r8+ qstp(i,k) / eps1) * rl * eps1 / & - (rd * tp(i,k) ** 2) - a2(i) = .5_r8* (qstp(i,k)* (1._r8+2._r8/eps1*qstp(i,k))* & - (1._r8+qstp(i,k)/eps1)*eps1**2*rl*rl/ & - (rd**2*tp(i,k)**4)-qstp(i,k)* & - (1._r8+qstp(i,k)/eps1)*2._r8*eps1*rl/ & - (rd*tp(i,k)**3)) - a1(i) = 1._r8/a1(i) - a2(i) = -a2(i)*a1(i)**3 - y(i) = q(i,mx(i)) - qstp(i,k) - tp(i,k) = tp(i,k) + a1(i)*y(i) + a2(i)*y(i)**2 - call qsat_hPa(tp(i,k), p(i,k), estp(i), qstp(i,k)) -! -! buoyancy is increased by 0.5 k in cape calculation. -! dec. 9, 1994 -!-jjh tpv(i,k) =tp(i,k)*(1.+1.608*qstp(i,k))/(1.+q(i,mx(i))) -! - tpv(i,k) = (tp(i,k)+tpert(i))* (1._r8+1.608_r8*qstp(i,k)) / (1._r8+q(i,mx(i))) - buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add - end if - end do - end do -! -! main buoyancy calculation. -! - do k = pver - 1,msg + 1,-1 - do i=1,ncol - if (k < lcl(i) .and. plge600(i)) then - tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k)) - qstp(i,k) = qstp(i,k+1) - tp(i,k) = tp(i,k+1)* (p(i,k)/p(i,k+1))**(0.2854_r8* (1._r8-0.28_r8*qstp(i,k))) - call qsat_hPa(tp(i,k), p(i,k), estp(i), qstp(i,k)) - a1(i) = cp/rl + qstp(i,k)* (1._r8+qstp(i,k)/eps1)*rl*eps1/ (rd*tp(i,k)**2) - a2(i) = .5_r8* (qstp(i,k)* (1._r8+2._r8/eps1*qstp(i,k))* & - (1._r8+qstp(i,k)/eps1)*eps1**2*rl*rl/ & - (rd**2*tp(i,k)**4)-qstp(i,k)* & - (1._r8+qstp(i,k)/eps1)*2._r8*eps1*rl/ & - (rd*tp(i,k)**3)) - a1(i) = 1._r8/a1(i) - a2(i) = -a2(i)*a1(i)**3 - y(i) = qstp(i,k+1) - qstp(i,k) - tp(i,k) = tp(i,k) + a1(i)*y(i) + a2(i)*y(i)**2 - call qsat_hPa(tp(i,k), p(i,k), estp(i), qstp(i,k)) -!-jjh tpv(i,k) =tp(i,k)*(1.+1.608*qstp(i,k))/ -!jt (1.+q(i,mx(i))) - tpv(i,k) = (tp(i,k)+tpert(i))* (1._r8+1.608_r8*qstp(i,k))/(1._r8+q(i,mx(i))) - buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add - end if - end do - end do - -! - do k = msg + 2,pver - do i = 1,ncol - if (k < lcl(i) .and. plge600(i)) then - if (buoy(i,k+1) > 0._r8 .and. buoy(i,k) <= 0._r8) then - knt(i) = min(5,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,5 - do k = msg + 1,pver - do i = 1,ncol - if (plge600(i) .and. k <= mx(i) .and. k > lelten(i,n)) then - capeten(i,n) = capeten(i,n) + rd*buoy(i,k)*log(pf(i,k+1)/pf(i,k)) - 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,5 - do i = 1,ncol - if (capeten(i,n) > cape(i)) then - cape(i) = capeten(i,n) - lel(i) = lelten(i,n) - end if - end do - end do -! -! put lower bound on cape for diagnostic purposes. -! - do i = 1,ncol - cape(i) = max(cape(i), 0._r8) - end do -! - return -end subroutine buoyan - -subroutine cldprp(lchnk , & - q ,t ,u ,v ,p , & - z ,s ,mu ,eu ,du , & - md ,ed ,sd ,qd ,mc , & - qu ,su ,zf ,qst ,hmn , & - hsat ,shat ,ql , & - cmeg ,jb ,lel ,jt ,jlcl , & - mx ,j0 ,jd ,rl ,il2g , & - rd ,grav ,cp ,msg , & - pflx ,evp ,cu ,rprd ,limcnv ,landfrac, & - qcde ,aero ,loc_conv,qhat ) - -!----------------------------------------------------------------------- -! -! Purpose: -! -! -! Method: -! may 09/91 - guang jun zhang, m.lazare, n.mcfarlane. -! original version cldprop. -! -! Author: See above, modified by P. Rasch -! This is contributed code not fully standardized by the CCM core group. -! -! this code is very much rougher than virtually anything else in the CCM -! there are debug statements left strewn about and code segments disabled -! these are to facilitate future development. We expect to release a -! cleaner code in a future release -! -! the documentation has been enhanced to the degree that we are able -! -!----------------------------------------------------------------------- - - implicit none - -!------------------------------------------------------------------------------ -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - - real(r8), intent(in) :: q(pcols,pver) ! spec. humidity of env - real(r8), intent(in) :: t(pcols,pver) ! temp of env - real(r8), intent(in) :: p(pcols,pver) ! pressure of env - real(r8), intent(in) :: z(pcols,pver) ! height of env - real(r8), intent(in) :: s(pcols,pver) ! normalized dry static energy of env - real(r8), intent(in) :: zf(pcols,pverp) ! height of interfaces - real(r8), intent(in) :: u(pcols,pver) ! zonal velocity of env - real(r8), intent(in) :: v(pcols,pver) ! merid. velocity of env - - real(r8), intent(in) :: landfrac(pcols) ! RBN Landfrac - - integer, intent(in) :: jb(pcols) ! updraft base level - integer, intent(in) :: lel(pcols) ! updraft launch level - integer, intent(out) :: jt(pcols) ! updraft plume top - integer, intent(out) :: jlcl(pcols) ! updraft lifting cond level - integer, intent(in) :: mx(pcols) ! updraft base level (same is jb) - integer, intent(out) :: j0(pcols) ! level where updraft begins detraining - integer, intent(out) :: jd(pcols) ! level of downdraft - integer, intent(in) :: limcnv ! convection limiting level - integer, intent(in) :: il2g !CORE GROUP REMOVE - integer, intent(in) :: msg ! missing moisture vals (always 0) - real(r8), intent(in) :: rl ! latent heat of vap - real(r8), intent(in) :: shat(pcols,pver) ! interface values of dry stat energy - real(r8), intent(in) :: qhat(pcols,pver) ! wg grid slice of upper interface mixing ratio. - type(zm_aero_t), intent(in) :: aero ! aerosol object - -! -! output -! - real(r8), intent(out) :: rprd(pcols,pver) ! rate of production of precip at that layer - real(r8), intent(out) :: du(pcols,pver) ! detrainement rate of updraft - real(r8), intent(out) :: ed(pcols,pver) ! entrainment rate of downdraft - real(r8), intent(out) :: eu(pcols,pver) ! entrainment rate of updraft - real(r8), intent(out) :: hmn(pcols,pver) ! moist stat energy of env - real(r8), intent(out) :: hsat(pcols,pver) ! sat moist stat energy of env - real(r8), intent(out) :: mc(pcols,pver) ! net mass flux - real(r8), intent(out) :: md(pcols,pver) ! downdraft mass flux - real(r8), intent(out) :: mu(pcols,pver) ! updraft mass flux - real(r8), intent(out) :: pflx(pcols,pverp) ! precipitation flux thru layer - real(r8), intent(out) :: qd(pcols,pver) ! spec humidity of downdraft - real(r8), intent(out) :: ql(pcols,pver) ! liq water of updraft - real(r8), intent(out) :: qst(pcols,pver) ! saturation mixing ratio of env. - real(r8), intent(out) :: qu(pcols,pver) ! spec hum of updraft - real(r8), intent(out) :: sd(pcols,pver) ! normalized dry stat energy of downdraft - real(r8), intent(out) :: su(pcols,pver) ! normalized dry stat energy of updraft - real(r8), intent(out) :: qcde(pcols,pver) ! cloud water mixing ratio for detrainment (kg/kg) - - type(zm_conv_t) :: loc_conv - - real(r8) rd ! gas constant for dry air - real(r8) grav ! gravity - real(r8) cp ! heat capacity of dry air - -! -! Local workspace -! - real(r8) gamma(pcols,pver) - real(r8) dz(pcols,pver) - real(r8) iprm(pcols,pver) - real(r8) hu(pcols,pver) - real(r8) hd(pcols,pver) - real(r8) eps(pcols,pver) - real(r8) f(pcols,pver) - real(r8) k1(pcols,pver) - real(r8) i2(pcols,pver) - real(r8) ihat(pcols,pver) - real(r8) i3(pcols,pver) - real(r8) idag(pcols,pver) - real(r8) i4(pcols,pver) - real(r8) qsthat(pcols,pver) - real(r8) hsthat(pcols,pver) - real(r8) gamhat(pcols,pver) - real(r8) cu(pcols,pver) - real(r8) evp(pcols,pver) - real(r8) cmeg(pcols,pver) - real(r8) qds(pcols,pver) -! RBN For c0mask - real(r8) c0mask(pcols) - - real(r8) hmin(pcols) - real(r8) expdif(pcols) - real(r8) expnum(pcols) - real(r8) ftemp(pcols) - real(r8) eps0(pcols) - real(r8) rmue(pcols) - real(r8) zuef(pcols) - real(r8) zdef(pcols) - real(r8) epsm(pcols) - real(r8) ratmjb(pcols) - real(r8) est(pcols) - real(r8) totpcp(pcols) - real(r8) totevp(pcols) - real(r8) alfa(pcols) - real(r8) ql1 - real(r8) tu - real(r8) estu - real(r8) qstu - - real(r8) small - real(r8) mdt - - real(r8) fice(pcols,pver) ! ice fraction in precip production - real(r8) tug(pcols,pver) - - real(r8) tvuo(pcols,pver) ! updraft virtual T w/o freezing heating - real(r8) tvu(pcols,pver) ! updraft virtual T with freezing heating - real(r8) totfrz(pcols) - real(r8) frz (pcols,pver) ! rate of freezing - integer jto(pcols) ! updraft plume old top - integer tmplel(pcols) - - integer iter, itnum - integer m - - integer khighest - integer klowest - integer kount - integer i,k - - logical doit(pcols) - logical done(pcols) -! -!------------------------------------------------------------------------------ -! - if (zmconv_microp) then - loc_conv%autolm(:il2g,:) = 0._r8 - loc_conv%accrlm(:il2g,:) = 0._r8 - loc_conv%bergnm(:il2g,:) = 0._r8 - loc_conv%fhtimm(:il2g,:) = 0._r8 - loc_conv%fhtctm(:il2g,:) = 0._r8 - loc_conv%fhmlm (:il2g,:) = 0._r8 - loc_conv%hmpim (:il2g,:) = 0._r8 - loc_conv%accslm(:il2g,:) = 0._r8 - loc_conv%dlfm (:il2g,:) = 0._r8 - - loc_conv%autoln(:il2g,:) = 0._r8 - loc_conv%accrln(:il2g,:) = 0._r8 - loc_conv%bergnn(:il2g,:) = 0._r8 - loc_conv%fhtimn(:il2g,:) = 0._r8 - loc_conv%fhtctn(:il2g,:) = 0._r8 - loc_conv%fhmln (:il2g,:) = 0._r8 - loc_conv%accsln(:il2g,:) = 0._r8 - loc_conv%activn(:il2g,:) = 0._r8 - loc_conv%dlfn (:il2g,:) = 0._r8 - - loc_conv%autoim(:il2g,:) = 0._r8 - loc_conv%accsim(:il2g,:) = 0._r8 - loc_conv%difm (:il2g,:) = 0._r8 - - loc_conv%nuclin(:il2g,:) = 0._r8 - loc_conv%autoin(:il2g,:) = 0._r8 - loc_conv%accsin(:il2g,:) = 0._r8 - loc_conv%hmpin (:il2g,:) = 0._r8 - loc_conv%difn (:il2g,:) = 0._r8 - - loc_conv%trspcm(:il2g,:) = 0._r8 - loc_conv%trspcn(:il2g,:) = 0._r8 - loc_conv%trspim(:il2g,:) = 0._r8 - loc_conv%trspin(:il2g,:) = 0._r8 - - loc_conv%dcape (:il2g) = 0._r8 - - end if - - do i = 1,il2g - ftemp(i) = 0._r8 - expnum(i) = 0._r8 - expdif(i) = 0._r8 - c0mask(i) = c0_ocn * (1._r8-landfrac(i)) + c0_lnd * landfrac(i) - end do -! -!jr Change from msg+1 to 1 to prevent blowup -! - do k = 1,pver - do i = 1,il2g - dz(i,k) = zf(i,k) - zf(i,k+1) - end do - end do - -! -! initialize many output and work variables to zero -! - pflx(:il2g,1) = 0 - - do k = 1,pver - do i = 1,il2g - k1(i,k) = 0._r8 - i2(i,k) = 0._r8 - i3(i,k) = 0._r8 - i4(i,k) = 0._r8 - mu(i,k) = 0._r8 - f(i,k) = 0._r8 - eps(i,k) = 0._r8 - eu(i,k) = 0._r8 - du(i,k) = 0._r8 - ql(i,k) = 0._r8 - cu(i,k) = 0._r8 - evp(i,k) = 0._r8 - cmeg(i,k) = 0._r8 - qds(i,k) = q(i,k) - md(i,k) = 0._r8 - ed(i,k) = 0._r8 - sd(i,k) = s(i,k) - qd(i,k) = q(i,k) - mc(i,k) = 0._r8 - qu(i,k) = q(i,k) - su(i,k) = s(i,k) - call qsat_hPa(t(i,k), p(i,k), est(i), qst(i,k)) - - if ( p(i,k)-est(i) <= 0._r8 ) then - qst(i,k) = 1.0_r8 - end if - - gamma(i,k) = qst(i,k)*(1._r8 + qst(i,k)/eps1)*eps1*rl/(rd*t(i,k)**2)*rl/cp - hmn(i,k) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k) - hsat(i,k) = cp*t(i,k) + grav*z(i,k) + rl*qst(i,k) - hu(i,k) = hmn(i,k) - hd(i,k) = hmn(i,k) - rprd(i,k) = 0._r8 - - fice(i,k) = 0._r8 - tug(i,k) = 0._r8 - qcde(i,k) = 0._r8 - tvuo(i,k) = (shat(i,k) - grav/cp*zf(i,k))*(1._r8 + 0.608_r8*qhat(i,k)) - tvu(i,k) = tvuo(i,k) - frz(i,k) = 0._r8 - - end do - end do - if (zmconv_microp) then - do k = 1,pver - do i = 1,il2g - loc_conv%sprd(i,k) = 0._r8 - loc_conv%wu(i,k) = 0._r8 - loc_conv%cmel(i,k) = 0._r8 - loc_conv%cmei(i,k) = 0._r8 - loc_conv%qliq(i,k) = 0._r8 - loc_conv%qice(i,k) = 0._r8 - loc_conv%qnl(i,k) = 0._r8 - loc_conv%qni(i,k) = 0._r8 - loc_conv%qide(i,k) = 0._r8 - loc_conv%qncde(i,k) = 0._r8 - loc_conv%qnide(i,k) = 0._r8 - loc_conv%qnr(i,k) = 0._r8 - loc_conv%qns(i,k) = 0._r8 - loc_conv%qrain(i,k)= 0._r8 - loc_conv%qsnow(i,k)= 0._r8 - loc_conv%frz(i,k) = 0._r8 - end do - end do - end if -! -!jr Set to zero things which make this routine blow up -! - do k=1,msg - do i=1,il2g - rprd(i,k) = 0._r8 - end do - end do -! -! interpolate the layer values of qst, hsat and gamma to -! layer interfaces -! - do k = 1, msg+1 - do i = 1,il2g - hsthat(i,k) = hsat(i,k) - qsthat(i,k) = qst(i,k) - gamhat(i,k) = gamma(i,k) - end do - end do - do i = 1,il2g - totpcp(i) = 0._r8 - totevp(i) = 0._r8 - end do - do k = msg + 2,pver - do i = 1,il2g - if (abs(qst(i,k-1)-qst(i,k)) > 1.E-6_r8) then - qsthat(i,k) = log(qst(i,k-1)/qst(i,k))*qst(i,k-1)*qst(i,k)/ (qst(i,k-1)-qst(i,k)) - else - qsthat(i,k) = qst(i,k) - end if - hsthat(i,k) = cp*shat(i,k) + rl*qsthat(i,k) - if (abs(gamma(i,k-1)-gamma(i,k)) > 1.E-6_r8) then - gamhat(i,k) = log(gamma(i,k-1)/gamma(i,k))*gamma(i,k-1)*gamma(i,k)/ & - (gamma(i,k-1)-gamma(i,k)) - else - gamhat(i,k) = gamma(i,k) - end if - end do - end do -! -! initialize cloud top to highest plume top. -!jr changed hard-wired 4 to limcnv+1 (not to exceed pver) -! - jt(:) = pver - do i = 1,il2g - jt(i) = max(lel(i),limcnv+1) - jt(i) = min(jt(i),pver) - jd(i) = pver - jlcl(i) = lel(i) - hmin(i) = 1.E6_r8 - end do -! -! find the level of minimum hsat, where detrainment starts -! - - do k = msg + 1,pver - do i = 1,il2g - if (hsat(i,k) <= hmin(i) .and. k >= jt(i) .and. k <= jb(i)) then - hmin(i) = hsat(i,k) - j0(i) = k - end if - end do - end do - do i = 1,il2g - j0(i) = min(j0(i),jb(i)-2) - j0(i) = max(j0(i),jt(i)+2) -! -! Fix from Guang Zhang to address out of bounds array reference -! - j0(i) = min(j0(i),pver) - end do -! -! Initialize certain arrays inside cloud -! - do k = msg + 1,pver - do i = 1,il2g - if (k >= jt(i) .and. k <= jb(i)) then - hu(i,k) = hmn(i,mx(i)) + cp*tiedke_add - su(i,k) = s(i,mx(i)) + tiedke_add - end if - end do - end do -! -! ********************************************************* -! compute taylor series for approximate eps(z) below -! ********************************************************* -! - do k = pver - 1,msg + 1,-1 - do i = 1,il2g - if (k < jb(i) .and. k >= jt(i)) then - k1(i,k) = k1(i,k+1) + (hmn(i,mx(i))-hmn(i,k))*dz(i,k) - ihat(i,k) = 0.5_r8* (k1(i,k+1)+k1(i,k)) - i2(i,k) = i2(i,k+1) + ihat(i,k)*dz(i,k) - idag(i,k) = 0.5_r8* (i2(i,k+1)+i2(i,k)) - i3(i,k) = i3(i,k+1) + idag(i,k)*dz(i,k) - iprm(i,k) = 0.5_r8* (i3(i,k+1)+i3(i,k)) - i4(i,k) = i4(i,k+1) + iprm(i,k)*dz(i,k) - end if - end do - end do -! -! re-initialize hmin array for ensuing calculation. -! - do i = 1,il2g - hmin(i) = 1.E6_r8 - end do - do k = msg + 1,pver - do i = 1,il2g - if (k >= j0(i) .and. k <= jb(i) .and. hmn(i,k) <= hmin(i)) then - hmin(i) = hmn(i,k) - expdif(i) = hmn(i,mx(i)) - hmin(i) - end if - end do - end do -! -! ********************************************************* -! compute approximate eps(z) using above taylor series -! ********************************************************* -! - do k = msg + 2,pver - do i = 1,il2g - expnum(i) = 0._r8 - ftemp(i) = 0._r8 - if (k < jt(i) .or. k >= jb(i)) then - k1(i,k) = 0._r8 - expnum(i) = 0._r8 - else - expnum(i) = hmn(i,mx(i)) - (hsat(i,k-1)*(zf(i,k)-z(i,k)) + & - hsat(i,k)* (z(i,k-1)-zf(i,k)))/(z(i,k-1)-z(i,k)) - end if - if ((expdif(i) > 100._r8 .and. expnum(i) > 0._r8) .and. & - k1(i,k) > expnum(i)*dz(i,k)) then - ftemp(i) = expnum(i)/k1(i,k) - f(i,k) = ftemp(i) + i2(i,k)/k1(i,k)*ftemp(i)**2 + & - (2._r8*i2(i,k)**2-k1(i,k)*i3(i,k))/k1(i,k)**2* & - ftemp(i)**3 + (-5._r8*k1(i,k)*i2(i,k)*i3(i,k)+ & - 5._r8*i2(i,k)**3+k1(i,k)**2*i4(i,k))/ & - k1(i,k)**3*ftemp(i)**4 - f(i,k) = max(f(i,k),0._r8) - f(i,k) = min(f(i,k),0.0002_r8) - end if - end do - end do - do i = 1,il2g - if (j0(i) < jb(i)) then - if (f(i,j0(i)) < 1.E-6_r8 .and. f(i,j0(i)+1) > f(i,j0(i))) j0(i) = j0(i) + 1 - end if - end do - do k = msg + 2,pver - do i = 1,il2g - if (k >= jt(i) .and. k <= j0(i)) then - f(i,k) = max(f(i,k),f(i,k-1)) - end if - end do - end do - do i = 1,il2g - eps0(i) = f(i,j0(i)) - eps(i,jb(i)) = eps0(i) - end do -! -! This is set to match the Rasch and Kristjansson paper -! - do k = pver,msg + 1,-1 - do i = 1,il2g - if (k >= j0(i) .and. k <= jb(i)) then - eps(i,k) = f(i,j0(i)) - end if - end do - end do - do k = pver,msg + 1,-1 - do i = 1,il2g - if (k < j0(i) .and. k >= jt(i)) eps(i,k) = f(i,k) - end do - end do - - if (zmconv_microp) then - itnum = 2 - else - itnum = 1 - end if - - do iter=1, itnum - - if (zmconv_microp) then - do k = pver,msg + 1,-1 - do i = 1,il2g - cu(i,k) = 0._r8 - loc_conv%qliq(i,k) = 0._r8 - loc_conv%qice(i,k) = 0._r8 - ql(i,k) = 0._r8 - loc_conv%frz(i,k) = 0._r8 - end do - end do - do i = 1,il2g - totpcp(i) = 0._r8 - hu(i,jb(i)) = hmn(i,jb(i)) + cp*tiedke_add - end do - - end if - -! -! specify the updraft mass flux mu, entrainment eu, detrainment du -! and moist static energy hu. -! here and below mu, eu,du, md and ed are all normalized by mb -! - do i = 1,il2g - if (eps0(i) > 0._r8) then - mu(i,jb(i)) = 1._r8 - eu(i,jb(i)) = mu(i,jb(i))/dz(i,jb(i)) - end if - if (zmconv_microp) then - tmplel(i) = lel(i) - else - tmplel(i) = jt(i) - end if - end do - do k = pver,msg + 1,-1 - do i = 1,il2g - if (eps0(i) > 0._r8 .and. (k >= tmplel(i) .and. k < jb(i))) then - zuef(i) = zf(i,k) - zf(i,jb(i)) - rmue(i) = (1._r8/eps0(i))* (exp(eps(i,k+1)*zuef(i))-1._r8)/zuef(i) - mu(i,k) = (1._r8/eps0(i))* (exp(eps(i,k )*zuef(i))-1._r8)/zuef(i) - eu(i,k) = (rmue(i)-mu(i,k+1))/dz(i,k) - du(i,k) = (rmue(i)-mu(i,k))/dz(i,k) - end if - end do - end do - - khighest = pverp - klowest = 1 - do i=1,il2g - khighest = min(khighest,lel(i)) - klowest = max(klowest,jb(i)) - end do - do k = klowest-1,khighest,-1 - do i = 1,il2g - if (k <= jb(i)-1 .and. k >= lel(i) .and. eps0(i) > 0._r8) then - if (mu(i,k) < 0.02_r8) then - hu(i,k) = hmn(i,k) - mu(i,k) = 0._r8 - eu(i,k) = 0._r8 - du(i,k) = mu(i,k+1)/dz(i,k) - else - if (zmconv_microp) then - hu(i,k) = (mu(i,k+1)*hu(i,k+1) + dz(i,k)*(eu(i,k)*hmn(i,k) + & - latice*frz(i,k)))/(mu(i,k)+ dz(i,k)*du(i,k)) - else - hu(i,k) = mu(i,k+1)/mu(i,k)*hu(i,k+1) + & - dz(i,k)/mu(i,k)* (eu(i,k)*hmn(i,k)- du(i,k)*hsat(i,k)) - end if - end if - end if - end do - end do -! -! reset cloud top index beginning from two layers above the -! cloud base (i.e. if cloud is only one layer thick, top is not reset -! - do i=1,il2g - doit(i) = .true. - totfrz(i)= 0._r8 - do k = pver,msg + 1,-1 - totfrz(i)= totfrz(i)+ frz(i,k)*dz(i,k) - end do - end do - do k=klowest-2,khighest-1,-1 - do i=1,il2g - if (doit(i) .and. k <= jb(i)-2 .and. k >= lel(i)-1) then - if (hu(i,k) <= hsthat(i,k) .and. hu(i,k+1) > hsthat(i,k+1) & - .and. mu(i,k) >= 0.02_r8) then - if (hu(i,k)-hsthat(i,k) < -2000._r8) then - jt(i) = k + 1 - doit(i) = .false. - else - jt(i) = k - doit(i) = .false. - end if - else if ( (hu(i,k) > hu(i,jb(i)) .and. totfrz(i)<=0._r8) .or. mu(i,k) < 0.02_r8) then - jt(i) = k + 1 - doit(i) = .false. - end if - end if - end do - end do - - if (iter == 1) jto(:) = jt(:) - - do k = pver,msg + 1,-1 - do i = 1,il2g - if (k >= lel(i) .and. k <= jt(i) .and. eps0(i) > 0._r8) then - mu(i,k) = 0._r8 - eu(i,k) = 0._r8 - du(i,k) = 0._r8 - hu(i,k) = hmn(i,k) - end if - if (k == jt(i) .and. eps0(i) > 0._r8) then - du(i,k) = mu(i,k+1)/dz(i,k) - eu(i,k) = 0._r8 - mu(i,k) = 0._r8 - end if - end do - end do - - do i = 1,il2g - done(i) = .false. - end do - kount = 0 - do k = pver,msg + 2,-1 - do i = 1,il2g - if (k == jb(i) .and. eps0(i) > 0._r8) then - qu(i,k) = q(i,mx(i)) - su(i,k) = (hu(i,k)-rl*qu(i,k))/cp - end if - if (( .not. done(i) .and. k > jt(i) .and. k < jb(i)) .and. eps0(i) > 0._r8) then - su(i,k) = mu(i,k+1)/mu(i,k)*su(i,k+1) + & - dz(i,k)/mu(i,k)* (eu(i,k)-du(i,k))*s(i,k) - qu(i,k) = mu(i,k+1)/mu(i,k)*qu(i,k+1) + dz(i,k)/mu(i,k)* (eu(i,k)*q(i,k)- & - du(i,k)*qst(i,k)) - tu = su(i,k) - grav/cp*zf(i,k) - call qsat_hPa(tu, (p(i,k)+p(i,k-1))/2._r8, estu, qstu) - if (qu(i,k) >= qstu) then - jlcl(i) = k - kount = kount + 1 - done(i) = .true. - end if - end if - end do - if (kount >= il2g) goto 690 - end do -690 continue - do k = msg + 2,pver - do i = 1,il2g - if ((k > jt(i) .and. k <= jlcl(i)) .and. eps0(i) > 0._r8) then - su(i,k) = shat(i,k) + (hu(i,k)-hsthat(i,k))/(cp* (1._r8+gamhat(i,k))) - qu(i,k) = qsthat(i,k) + gamhat(i,k)*(hu(i,k)-hsthat(i,k))/ & - (rl* (1._r8+gamhat(i,k))) - end if - end do - end do - -! compute condensation in updraft - if (zmconv_microp) then - tmplel(:il2g) = jlcl(:il2g)+1 - else - tmplel(:il2g) = jb(:il2g) - end if - - do k = pver,msg + 2,-1 - do i = 1,il2g - if (k >= jt(i) .and. k < tmplel(i) .and. eps0(i) > 0._r8) then - if (zmconv_microp) then - cu(i,k) = ((mu(i,k)*su(i,k)-mu(i,k+1)*su(i,k+1))/ & - dz(i,k)- eu(i,k)*s(i,k)+du(i,k)*su(i,k))/(rl/cp) & - - latice*frz(i,k)/rl - else - - cu(i,k) = ((mu(i,k)*su(i,k)-mu(i,k+1)*su(i,k+1))/ & - dz(i,k)- (eu(i,k)-du(i,k))*s(i,k))/(rl/cp) - end if - if (k == jt(i)) cu(i,k) = 0._r8 - cu(i,k) = max(0._r8,cu(i,k)) - end if - end do - end do - - - if (zmconv_microp) then - - tug(:il2g,:) = t(:il2g,:) - fice(:,:) = 0._r8 - - do k = pver, msg+2, -1 - do i = 1, il2g - tug(i,k) = su(i,k) - grav/cp*zf(i,k) - end do - end do - - do k = 1, pver-1 - do i = 1, il2g - - if (tug(i,k+1) > 273.15_r8) then - ! If warmer than tmax then water phase - fice(i,k) = 0._r8 - - else if (tug(i,k+1) < 233.15_r8) then - ! If colder than tmin then ice phase - fice(i,k) = 1._r8 - - else - ! Otherwise mixed phase, with ice fraction decreasing linearly - ! from tmin to tmax - fice(i,k) =(273.15_r8 - tug(i,k+1)) / 40._r8 - end if - end do - end do - - do k = 1, pver - do i = 1,il2g - loc_conv%cmei(i,k) = cu(i,k)* fice(i,k) - loc_conv%cmel(i,k) = cu(i,k) * (1._r8-fice(i,k)) - end do - end do - - call zm_mphy(su, qu, mu, du, eu, loc_conv%cmel, loc_conv%cmei, zf, p, t, q, & - eps0, jb, jt, jlcl, msg, il2g, grav, cp, rd, aero, gamhat, & - loc_conv%qliq, loc_conv%qice, loc_conv%qnl, loc_conv%qni, qcde, loc_conv%qide, & - loc_conv%qncde, loc_conv%qnide, rprd, loc_conv%sprd, frz, & - loc_conv%wu, loc_conv%qrain, loc_conv%qsnow, loc_conv%qnr, loc_conv%qns, & - loc_conv%autolm, loc_conv%accrlm, loc_conv%bergnm, loc_conv%fhtimm, loc_conv%fhtctm, & - loc_conv%fhmlm, loc_conv%hmpim, loc_conv%accslm, loc_conv%dlfm, loc_conv%autoln, & - loc_conv%accrln, loc_conv%bergnn, loc_conv%fhtimn, loc_conv%fhtctn, & - loc_conv%fhmln, loc_conv%accsln, loc_conv%activn, loc_conv%dlfn, loc_conv%autoim, & - loc_conv%accsim, loc_conv%difm, loc_conv%nuclin, loc_conv%autoin, & - loc_conv%accsin, loc_conv%hmpin, loc_conv%difn, loc_conv%trspcm, loc_conv%trspcn, & - loc_conv%trspim, loc_conv%trspin, loc_conv%lambdadpcu, loc_conv%mudpcu ) - - - do k = pver,msg + 2,-1 - do i = 1,il2g - ql(i,k) = loc_conv%qliq(i,k)+ loc_conv%qice(i,k) - loc_conv%frz(i,k) = frz(i,k) - end do - end do - - do i = 1,il2g - if (iter == 2 .and. jt(i)> jto(i)) then - do k = jt(i), jto(i), -1 - loc_conv%frz(i,k) = 0.0_r8 - cu(i,k)=0.0_r8 - end do - end if - end do - - - do k = pver,msg + 2,-1 - do i = 1,il2g - if (k >= jt(i) .and. k < jb(i) .and. eps0(i) > 0._r8 .and. mu(i,k) >= 0.0_r8) then - totpcp(i) = totpcp(i) + dz(i,k)*(cu(i,k)-du(i,k)*(qcde(i,k+1)+loc_conv%qide(i,k+1) )) - end if - end do - end do - - do k = msg + 2,pver - do i = 1,il2g - if ((k > jt(i) .and. k <= jlcl(i)) .and. eps0(i) > 0._r8) then - if (iter == 1) tvuo(i,k)= (su(i,k) - grav/cp*zf(i,k))*(1._r8+0.608_r8*qu(i,k)) - if (iter == 2 .and. k > max(jt(i),jto(i)) ) then - tvu(i,k) = (su(i,k) - grav/cp*zf(i,k))*(1._r8 +0.608_r8*qu(i,k)) - loc_conv%dcape(i) = loc_conv%dcape(i)+ rd*(tvu(i,k)-tvuo(i,k))*log(p(i,k)/p(i,k-1)) - end if - end if - end do - end do - - else ! no convective microphysics - -! compute condensed liquid, rain production rate -! accumulate total precipitation (condensation - detrainment of liquid) -! Note ql1 = ql(k) + rprd(k)*dz(k)/mu(k) -! The differencing is somewhat strange (e.g. du(i,k)*ql(i,k+1)) but is -! consistently applied. -! mu, ql are interface quantities -! cu, du, eu, rprd are midpoint quantites - - do k = pver,msg + 2,-1 - do i = 1,il2g - rprd(i,k) = 0._r8 - if (k >= jt(i) .and. k < jb(i) .and. eps0(i) > 0._r8 .and. mu(i,k) >= 0.0_r8) then - if (mu(i,k) > 0._r8) then - ql1 = 1._r8/mu(i,k)* (mu(i,k+1)*ql(i,k+1)- & - dz(i,k)*du(i,k)*ql(i,k+1)+dz(i,k)*cu(i,k)) - ql(i,k) = ql1/ (1._r8+dz(i,k)*c0mask(i)) - else - ql(i,k) = 0._r8 - end if - totpcp(i) = totpcp(i) + dz(i,k)*(cu(i,k)-du(i,k)*ql(i,k+1)) - rprd(i,k) = c0mask(i)*mu(i,k)*ql(i,k) - qcde(i,k) = ql(i,k) - - if (zmconv_microp) then - loc_conv%qide(i,k) = 0._r8 - loc_conv%qncde(i,k) = 0._r8 - loc_conv%qnide(i,k) = 0._r8 - loc_conv%sprd(i,k) = 0._r8 - end if - - end if - end do - end do -! - end if ! zmconv_microp - - end do !iter -! -! specify downdraft properties (no downdrafts if jd.ge.jb). -! scale down downward mass flux profile so that net flux -! (up-down) at cloud base in not negative. -! - do i = 1,il2g -! -! in normal downdraft strength run alfa=0.2. In test4 alfa=0.1 -! - alfa(i) = 0.1_r8 - jt(i) = min(jt(i),jb(i)-1) - jd(i) = max(j0(i),jt(i)+1) - jd(i) = min(jd(i),jb(i)) - hd(i,jd(i)) = hmn(i,jd(i)-1) - if (jd(i) < jb(i) .and. eps0(i) > 0._r8) then - epsm(i) = eps0(i) - md(i,jd(i)) = -alfa(i)*epsm(i)/eps0(i) - end if - end do - do k = msg + 1,pver - do i = 1,il2g - if ((k > jd(i) .and. k <= jb(i)) .and. eps0(i) > 0._r8) then - zdef(i) = zf(i,jd(i)) - zf(i,k) - md(i,k) = -alfa(i)/ (2._r8*eps0(i))*(exp(2._r8*epsm(i)*zdef(i))-1._r8)/zdef(i) - end if - end do - end do - - do k = msg + 1,pver - do i = 1,il2g - if ((k >= jt(i) .and. k <= jb(i)) .and. eps0(i) > 0._r8 .and. jd(i) < jb(i)) then - ratmjb(i) = min(abs(mu(i,jb(i))/md(i,jb(i))),1._r8) - md(i,k) = md(i,k)*ratmjb(i) - end if - end do - end do - - small = 1.e-20_r8 - do k = msg + 1,pver - do i = 1,il2g - if ((k >= jt(i) .and. k <= pver) .and. eps0(i) > 0._r8) then - ed(i,k-1) = (md(i,k-1)-md(i,k))/dz(i,k-1) - mdt = min(md(i,k),-small) - hd(i,k) = (md(i,k-1)*hd(i,k-1) - dz(i,k-1)*ed(i,k-1)*hmn(i,k-1))/mdt - end if - end do - end do -! -! calculate updraft and downdraft properties. -! - do k = msg + 2,pver - do i = 1,il2g - if ((k >= jd(i) .and. k <= jb(i)) .and. eps0(i) > 0._r8 .and. jd(i) < jb(i)) then - qds(i,k) = qsthat(i,k) + gamhat(i,k)*(hd(i,k)-hsthat(i,k))/ & - (rl*(1._r8 + gamhat(i,k))) - end if - end do - end do - - do i = 1,il2g - qd(i,jd(i)) = qds(i,jd(i)) - sd(i,jd(i)) = (hd(i,jd(i)) - rl*qd(i,jd(i)))/cp - end do -! - do k = msg + 2,pver - do i = 1,il2g - if (k >= jd(i) .and. k < jb(i) .and. eps0(i) > 0._r8) then - qd(i,k+1) = qds(i,k+1) - evp(i,k) = -ed(i,k)*q(i,k) + (md(i,k)*qd(i,k)-md(i,k+1)*qd(i,k+1))/dz(i,k) - evp(i,k) = max(evp(i,k),0._r8) - mdt = min(md(i,k+1),-small) - if (zmconv_microp) then - evp(i,k) = min(evp(i,k),rprd(i,k)) - end if - sd(i,k+1) = ((rl/cp*evp(i,k)-ed(i,k)*s(i,k))*dz(i,k) + md(i,k)*sd(i,k))/mdt - totevp(i) = totevp(i) - dz(i,k)*ed(i,k)*q(i,k) - end if - end do - end do - do i = 1,il2g -!*guang totevp(i) = totevp(i) + md(i,jd(i))*q(i,jd(i)-1) - - totevp(i) = totevp(i) + md(i,jd(i))*qd(i,jd(i)) - md(i,jb(i))*qd(i,jb(i)) - end do -!!$ if (.true.) then - if (.false.) then - do i = 1,il2g - k = jb(i) - if (eps0(i) > 0._r8) then - evp(i,k) = -ed(i,k)*q(i,k) + (md(i,k)*qd(i,k))/dz(i,k) - evp(i,k) = max(evp(i,k),0._r8) - totevp(i) = totevp(i) - dz(i,k)*ed(i,k)*q(i,k) - end if - end do - endif - - do i = 1,il2g - totpcp(i) = max(totpcp(i),0._r8) - totevp(i) = max(totevp(i),0._r8) - end do -! - do k = msg + 2,pver - do i = 1,il2g - if (totevp(i) > 0._r8 .and. totpcp(i) > 0._r8) then - md(i,k) = md (i,k)*min(1._r8, totpcp(i)/(totevp(i)+totpcp(i))) - ed(i,k) = ed (i,k)*min(1._r8, totpcp(i)/(totevp(i)+totpcp(i))) - evp(i,k) = evp(i,k)*min(1._r8, totpcp(i)/(totevp(i)+totpcp(i))) - else - md(i,k) = 0._r8 - ed(i,k) = 0._r8 - evp(i,k) = 0._r8 - end if -! cmeg is the cloud water condensed - rain water evaporated -! rprd is the cloud water converted to rain - (rain evaporated) - cmeg(i,k) = cu(i,k) - evp(i,k) - rprd(i,k) = rprd(i,k)-evp(i,k) - end do - end do - -! compute the net precipitation flux across interfaces - pflx(:il2g,1) = 0._r8 - do k = 2,pverp - do i = 1,il2g - pflx(i,k) = pflx(i,k-1) + rprd(i,k-1)*dz(i,k-1) - end do - end do -! - do k = msg + 1,pver - do i = 1,il2g - mc(i,k) = mu(i,k) + md(i,k) - end do - end do -! - return -end subroutine cldprp - -subroutine closure(lchnk , & - q ,t ,p ,z ,s , & - tp ,qs ,qu ,su ,mc , & - du ,mu ,md ,qd ,sd , & - qhat ,shat ,dp ,qstp ,zf , & - ql ,dsubcld ,mb ,cape ,tl , & - lcl ,lel ,jt ,mx ,il1g , & - il2g ,rd ,grav ,cp ,rl , & - msg ,capelmt ) -!----------------------------------------------------------------------- -! -! Purpose: -! -! -! Method: -! -! -! -! Author: G. Zhang and collaborators. CCM contact:P. Rasch -! This is contributed code not fully standardized by the CCM core group. -! -! this code is very much rougher than virtually anything else in the CCM -! We expect to release cleaner code in a future release -! -! the documentation has been enhanced to the degree that we are able -! -!----------------------------------------------------------------------- - -! -!-----------------------------Arguments--------------------------------- -! - integer, intent(in) :: lchnk ! chunk identifier - - real(r8), intent(inout) :: q(pcols,pver) ! spec humidity - real(r8), intent(inout) :: t(pcols,pver) ! temperature - real(r8), intent(inout) :: p(pcols,pver) ! pressure (mb) - real(r8), intent(inout) :: mb(pcols) ! cloud base mass flux - real(r8), intent(in) :: z(pcols,pver) ! height (m) - real(r8), intent(in) :: s(pcols,pver) ! normalized dry static energy - real(r8), intent(in) :: tp(pcols,pver) ! parcel temp - real(r8), intent(in) :: qs(pcols,pver) ! sat spec humidity - real(r8), intent(in) :: qu(pcols,pver) ! updraft spec. humidity - real(r8), intent(in) :: su(pcols,pver) ! normalized dry stat energy of updraft - real(r8), intent(in) :: mc(pcols,pver) ! net convective mass flux - real(r8), intent(in) :: du(pcols,pver) ! detrainment from updraft - real(r8), intent(in) :: mu(pcols,pver) ! mass flux of updraft - real(r8), intent(in) :: md(pcols,pver) ! mass flux of downdraft - real(r8), intent(in) :: qd(pcols,pver) ! spec. humidity of downdraft - real(r8), intent(in) :: sd(pcols,pver) ! dry static energy of downdraft - real(r8), intent(in) :: qhat(pcols,pver) ! environment spec humidity at interfaces - real(r8), intent(in) :: shat(pcols,pver) ! env. normalized dry static energy at intrfcs - real(r8), intent(in) :: dp(pcols,pver) ! pressure thickness of layers - real(r8), intent(in) :: qstp(pcols,pver) ! spec humidity of parcel - real(r8), intent(in) :: zf(pcols,pver+1) ! height of interface levels - real(r8), intent(in) :: ql(pcols,pver) ! liquid water mixing ratio - - real(r8), intent(in) :: cape(pcols) ! available pot. energy of column - real(r8), intent(in) :: tl(pcols) - real(r8), intent(in) :: dsubcld(pcols) ! thickness of subcloud layer - - integer, intent(in) :: lcl(pcols) ! index of lcl - integer, intent(in) :: lel(pcols) ! index of launch leve - integer, intent(in) :: jt(pcols) ! top of updraft - integer, intent(in) :: mx(pcols) ! base of updraft -! -!--------------------------Local variables------------------------------ -! - real(r8) dtpdt(pcols,pver) - real(r8) dqsdtp(pcols,pver) - real(r8) dtmdt(pcols,pver) - real(r8) dqmdt(pcols,pver) - real(r8) dboydt(pcols,pver) - real(r8) thetavp(pcols,pver) - real(r8) thetavm(pcols,pver) - - real(r8) dtbdt(pcols),dqbdt(pcols),dtldt(pcols) - real(r8) beta - real(r8) capelmt - real(r8) cp - real(r8) dadt(pcols) - real(r8) debdt - real(r8) dltaa - real(r8) eb - real(r8) grav - - integer i - integer il1g - integer il2g - integer k, kmin, kmax - integer msg - - real(r8) rd - real(r8) rl -! change of subcloud layer properties due to convection is -! related to cumulus updrafts and downdrafts. -! mc(z)=f(z)*mb, mub=betau*mb, mdb=betad*mb are used -! to define betau, betad and f(z). -! note that this implies all time derivatives are in effect -! time derivatives per unit cloud-base mass flux, i.e. they -! have units of 1/mb instead of 1/sec. -! - do i = il1g,il2g - mb(i) = 0._r8 - eb = p(i,mx(i))*q(i,mx(i))/ (eps1+q(i,mx(i))) - dtbdt(i) = (1._r8/dsubcld(i))* (mu(i,mx(i))*(shat(i,mx(i))-su(i,mx(i)))+ & - md(i,mx(i))* (shat(i,mx(i))-sd(i,mx(i)))) - dqbdt(i) = (1._r8/dsubcld(i))* (mu(i,mx(i))*(qhat(i,mx(i))-qu(i,mx(i)))+ & - md(i,mx(i))* (qhat(i,mx(i))-qd(i,mx(i)))) - debdt = eps1*p(i,mx(i))/ (eps1+q(i,mx(i)))**2*dqbdt(i) - dtldt(i) = -2840._r8* (3.5_r8/t(i,mx(i))*dtbdt(i)-debdt/eb)/ & - (3.5_r8*log(t(i,mx(i)))-log(eb)-4.805_r8)**2 - end do -! -! dtmdt and dqmdt are cumulus heating and drying. -! - do k = msg + 1,pver - do i = il1g,il2g - dtmdt(i,k) = 0._r8 - dqmdt(i,k) = 0._r8 - end do - end do -! - do k = msg + 1,pver - 1 - do i = il1g,il2g - if (k == jt(i)) then - dtmdt(i,k) = (1._r8/dp(i,k))*(mu(i,k+1)* (su(i,k+1)-shat(i,k+1)- & - rl/cp*ql(i,k+1))+md(i,k+1)* (sd(i,k+1)-shat(i,k+1))) - dqmdt(i,k) = (1._r8/dp(i,k))*(mu(i,k+1)* (qu(i,k+1)- & - qhat(i,k+1)+ql(i,k+1))+md(i,k+1)*(qd(i,k+1)-qhat(i,k+1))) - end if - end do - end do -! - beta = 0._r8 - do k = msg + 1,pver - 1 - do i = il1g,il2g - if (k > jt(i) .and. k < mx(i)) then - dtmdt(i,k) = (mc(i,k)* (shat(i,k)-s(i,k))+mc(i,k+1)* (s(i,k)-shat(i,k+1)))/ & - dp(i,k) - rl/cp*du(i,k)*(beta*ql(i,k)+ (1-beta)*ql(i,k+1)) -! dqmdt(i,k)=(mc(i,k)*(qhat(i,k)-q(i,k)) -! 1 +mc(i,k+1)*(q(i,k)-qhat(i,k+1)))/dp(i,k) -! 2 +du(i,k)*(qs(i,k)-q(i,k)) -! 3 +du(i,k)*(beta*ql(i,k)+(1-beta)*ql(i,k+1)) - - dqmdt(i,k) = (mu(i,k+1)* (qu(i,k+1)-qhat(i,k+1)+cp/rl* (su(i,k+1)-s(i,k)))- & - mu(i,k)* (qu(i,k)-qhat(i,k)+cp/rl*(su(i,k)-s(i,k)))+md(i,k+1)* & - (qd(i,k+1)-qhat(i,k+1)+cp/rl*(sd(i,k+1)-s(i,k)))-md(i,k)* & - (qd(i,k)-qhat(i,k)+cp/rl*(sd(i,k)-s(i,k))))/dp(i,k) + & - du(i,k)* (beta*ql(i,k)+(1-beta)*ql(i,k+1)) - end if - end do - end do -! - do k = msg + 1,pver - do i = il1g,il2g - if (k >= lel(i) .and. k <= lcl(i)) then - thetavp(i,k) = tp(i,k)* (1000._r8/p(i,k))** (rd/cp)*(1._r8+1.608_r8*qstp(i,k)-q(i,mx(i))) - thetavm(i,k) = t(i,k)* (1000._r8/p(i,k))** (rd/cp)*(1._r8+0.608_r8*q(i,k)) - dqsdtp(i,k) = qstp(i,k)* (1._r8+qstp(i,k)/eps1)*eps1*rl/(rd*tp(i,k)**2) -! -! dtpdt is the parcel temperature change due to change of -! subcloud layer properties during convection. -! - dtpdt(i,k) = tp(i,k)/ (1._r8+rl/cp* (dqsdtp(i,k)-qstp(i,k)/tp(i,k)))* & - (dtbdt(i)/t(i,mx(i))+rl/cp* (dqbdt(i)/tl(i)-q(i,mx(i))/ & - tl(i)**2*dtldt(i))) -! -! dboydt is the integrand of cape change. -! - dboydt(i,k) = ((dtpdt(i,k)/tp(i,k)+1._r8/(1._r8+1.608_r8*qstp(i,k)-q(i,mx(i)))* & - (1.608_r8 * dqsdtp(i,k) * dtpdt(i,k) -dqbdt(i))) - (dtmdt(i,k)/t(i,k)+0.608_r8/ & - (1._r8+0.608_r8*q(i,k))*dqmdt(i,k)))*grav*thetavp(i,k)/thetavm(i,k) - end if - end do - end do -! - do k = msg + 1,pver - do i = il1g,il2g - if (k > lcl(i) .and. k < mx(i)) then - thetavp(i,k) = tp(i,k)* (1000._r8/p(i,k))** (rd/cp)*(1._r8+0.608_r8*q(i,mx(i))) - thetavm(i,k) = t(i,k)* (1000._r8/p(i,k))** (rd/cp)*(1._r8+0.608_r8*q(i,k)) -! -! dboydt is the integrand of cape change. -! - dboydt(i,k) = (dtbdt(i)/t(i,mx(i))+0.608_r8/ (1._r8+0.608_r8*q(i,mx(i)))*dqbdt(i)- & - dtmdt(i,k)/t(i,k)-0.608_r8/ (1._r8+0.608_r8*q(i,k))*dqmdt(i,k))* & - grav*thetavp(i,k)/thetavm(i,k) - end if - end do - end do - -! -! buoyant energy change is set to 2/3*excess cape per 3 hours -! - dadt(il1g:il2g) = 0._r8 - kmin = minval(lel(il1g:il2g)) - kmax = maxval(mx(il1g:il2g)) - 1 - do k = kmin, kmax - do i = il1g,il2g - if ( k >= lel(i) .and. k <= mx(i) - 1) then - dadt(i) = dadt(i) + dboydt(i,k)* (zf(i,k)-zf(i,k+1)) - endif - end do - end do - do i = il1g,il2g - dltaa = -1._r8* (cape(i)-capelmt) - if (dadt(i) /= 0._r8) mb(i) = max(dltaa/tau/dadt(i),0._r8) - end do -! - return -end subroutine closure - -subroutine q1q2_pjr(lchnk , & - dqdt ,dsdt ,q ,qs ,qu , & - su ,du ,qhat ,shat ,dp , & - mu ,md ,sd ,qd ,ql , & - dsubcld ,jt ,mx ,il1g ,il2g , & - cp ,rl ,msg , & - dl ,evp ,cu , & - loc_conv) - - - implicit none - -!----------------------------------------------------------------------- -! -! Purpose: -! -! -! Method: -! -! -! -! Author: phil rasch dec 19 1995 -! -!----------------------------------------------------------------------- - - - real(r8), intent(in) :: cp - - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: il1g - integer, intent(in) :: il2g - integer, intent(in) :: msg - - real(r8), intent(in) :: q(pcols,pver) - real(r8), intent(in) :: qs(pcols,pver) - real(r8), intent(in) :: qu(pcols,pver) - real(r8), intent(in) :: su(pcols,pver) - real(r8), intent(in) :: du(pcols,pver) - real(r8), intent(in) :: qhat(pcols,pver) - real(r8), intent(in) :: shat(pcols,pver) - real(r8), intent(in) :: dp(pcols,pver) - real(r8), intent(in) :: mu(pcols,pver) - real(r8), intent(in) :: md(pcols,pver) - real(r8), intent(in) :: sd(pcols,pver) - real(r8), intent(in) :: qd(pcols,pver) - real(r8), intent(in) :: ql(pcols,pver) - real(r8), intent(in) :: evp(pcols,pver) - real(r8), intent(in) :: cu(pcols,pver) - real(r8), intent(in) :: dsubcld(pcols) - - real(r8),intent(out) :: dqdt(pcols,pver),dsdt(pcols,pver) - real(r8),intent(out) :: dl(pcols,pver) - - type(zm_conv_t) :: loc_conv - - integer kbm - integer ktm - integer jt(pcols) - integer mx(pcols) -! -! work fields: -! - integer i - integer k - - real(r8) emc - real(r8) rl -!------------------------------------------------------------------- - do k = msg + 1,pver - do i = il1g,il2g - dsdt(i,k) = 0._r8 - dqdt(i,k) = 0._r8 - dl(i,k) = 0._r8 - end do - end do - - if (zmconv_microp) then - do k = msg + 1,pver - do i = il1g,il2g - loc_conv%di(i,k) = 0._r8 - loc_conv%dnl(i,k) = 0._r8 - loc_conv%dni(i,k) = 0._r8 - end do - end do - end if -! -! find the highest level top and bottom levels of convection -! - ktm = pver - kbm = pver - do i = il1g, il2g - ktm = min(ktm,jt(i)) - kbm = min(kbm,mx(i)) - end do - - do k = ktm,pver-1 - do i = il1g,il2g - emc = -cu (i,k) & ! condensation in updraft - +evp(i,k) ! evaporating rain in downdraft - - dsdt(i,k) = -rl/cp*emc & - + (+mu(i,k+1)* (su(i,k+1)-shat(i,k+1)) & - -mu(i,k)* (su(i,k)-shat(i,k)) & - +md(i,k+1)* (sd(i,k+1)-shat(i,k+1)) & - -md(i,k)* (sd(i,k)-shat(i,k)) & - )/dp(i,k) - - if (zmconv_microp) dsdt(i,k) = dsdt(i,k) + latice/cp*loc_conv%frz(i,k) - - dqdt(i,k) = emc + & - (+mu(i,k+1)* (qu(i,k+1)-qhat(i,k+1)) & - -mu(i,k)* (qu(i,k)-qhat(i,k)) & - +md(i,k+1)* (qd(i,k+1)-qhat(i,k+1)) & - -md(i,k)* (qd(i,k)-qhat(i,k)) & - )/dp(i,k) - - dl(i,k) = du(i,k)*ql(i,k+1) - - if (zmconv_microp) then - loc_conv%di(i,k) = du(i,k)*loc_conv%qide(i,k+1) - loc_conv%dnl(i,k) = du(i,k)*loc_conv%qncde(i,k+1) - loc_conv%dni(i,k) = du(i,k)*loc_conv%qnide(i,k+1) - end if - - end do - end do - -! - do k = kbm,pver - do i = il1g,il2g - if (k == mx(i)) then - dsdt(i,k) = (1._r8/dsubcld(i))* & - (-mu(i,k)* (su(i,k)-shat(i,k)) & - -md(i,k)* (sd(i,k)-shat(i,k)) & - ) - dqdt(i,k) = (1._r8/dsubcld(i))* & - (-mu(i,k)*(qu(i,k)-qhat(i,k)) & - -md(i,k)*(qd(i,k)-qhat(i,k)) & - ) - else if (k > mx(i)) then - dsdt(i,k) = dsdt(i,k-1) - dqdt(i,k) = dqdt(i,k-1) - end if - end do - end do -! - return -end subroutine q1q2_pjr - -subroutine buoyan_dilute(lchnk ,ncol , & - q ,t ,p ,z ,pf , & - tp ,qstp ,tl ,rl ,cape , & - pblt ,lcl ,lel ,lon ,mx , & - rd ,grav ,cp ,msg , & - zi ,zs ,tpert ,org , 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) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - - real(r8), intent(in) :: q(pcols,pver) ! spec. humidity - real(r8), intent(in) :: t(pcols,pver) ! temperature - real(r8), intent(in) :: p(pcols,pver) ! pressure - real(r8), intent(in) :: z(pcols,pver) ! height - real(r8), intent(in) :: pf(pcols,pver+1) ! pressure at interfaces - real(r8), intent(in) :: pblt(pcols) ! index of pbl depth - real(r8), intent(in) :: tpert(pcols) ! perturbation temperature by pbl processes - -! Use z interface/surface relative values for PBL parcel calculations. - real(r8), intent(in) :: zi(pcols,pver+1) - real(r8), intent(in) :: zs(pcols) - -! -! output arguments -! - real(r8), intent(out) :: tp(pcols,pver) ! parcel temperature - real(r8), intent(out) :: qstp(pcols,pver) ! saturation mixing ratio of parcel (only above lcl, just q below). - real(r8), intent(out) :: tl(pcols) ! parcel temperature at lcl - real(r8), intent(out) :: cape(pcols) ! convective aval. pot. energy. - integer lcl(pcols) ! - integer lel(pcols) ! - integer lon(pcols) ! level of onset of deep convection - integer mx(pcols) ! level of max moist static energy - - real(r8), pointer :: org(:,:) ! organization parameter - real(r8), intent(in) :: landfrac(pcols) -! -!--------------------------Local Variables------------------------------ -! - real(r8) capeten(pcols,5) ! provisional value of cape - real(r8) tv(pcols,pver) ! - real(r8) tpv(pcols,pver) ! - real(r8) buoy(pcols,pver) - - real(r8) a1(pcols) - real(r8) a2(pcols) - real(r8) estp(pcols) - real(r8) pl(pcols) - real(r8) plexp(pcols) - real(r8) hmax(pcols) - real(r8) hmn(pcols) - real(r8) y(pcols) - - logical plge600(pcols) - integer knt(pcols) - integer lelten(pcols,5) - - - - -! Parcel property variables - - real(r8) :: hmn_lev(pcols,pver) ! Vertical profile of moist static energy for each column - real(r8) :: dp_lev(pcols,pver) ! Level dpressure between interfaces - real(r8) :: hmn_zdp(pcols,pver) ! Integrals of hmn_lev*dp_lev at each level - real(r8) :: q_zdp(pcols,pver) ! Integrals of q*dp_lev at each level - real(r8) :: dp_zfrac ! Fraction of vertical grid box below mixing top (usually pblt) - real(r8) :: parcel_dz(pcols) ! Depth of parcel mixing (usually parcel_hscale*parcel_dz) - real(r8) :: parcel_ztop(pcols) ! Height of parcel mixing (usually parcel_ztop+zm(nlev)) - real(r8) :: parcel_dp(pcols) ! Pressure integral over parcel mixing depth (usually pblt) - real(r8) :: parcel_hdp(pcols) ! Pressure*MSE integral over parcel mixing depth (usually pblt) - real(r8) :: parcel_qdp(pcols) ! Pressure*q integral over parcel mixing depth (usually pblt) - real(r8) :: pbl_dz(pcols) ! Previously diagnosed PBL height - real(r8) :: hpar(pcols) ! Initial MSE of the parcel - real(r8) :: qpar(pcols) ! Initial humidity of the parcel - real(r8) :: ql(pcols) ! Initial parcel humidity (for ientropy routine) - integer :: ipar ! Index for top of parcel mixing/launch level. - - - - - real(r8) cp - real(r8) e - real(r8) grav - - integer i - integer k - integer msg - integer n - - real(r8) rd - real(r8) rl - - -! Scaling of PBL height to give parcel mixing length for lparcel_pbl=True - - real(r8), parameter :: parcel_hscale = 0.5_r8 - - -! -!----------------------------------------------------------------------- -! - do n = 1,5 - do i = 1,ncol - lelten(i,n) = pver - capeten(i,n) = 0._r8 - end do - end do -! - do i = 1,ncol - lon(i) = pver - knt(i) = 0 - lel(i) = pver - mx(i) = lon(i) - cape(i) = 0._r8 - hmax(i) = 0._r8 - pbl_dz(i) = z(i,nint(pblt(i)))-zs(i) ! mid-point z (zm) reference to PBL depth - parcel_dz(i) = max(zi(i,pver),parcel_hscale*pbl_dz(i)) ! PBL mixing depth [parcel_hscale*Boundary, but no thinner than zi(i,pver)] - parcel_ztop(i) = parcel_dz(i)+zs(i) ! PBL mixing height ztop this is wrt zs=0 - parcel_hdp(i) = 0._r8 - parcel_dp(i) = 0._r8 - parcel_qdp(i) = 0._r8 - hpar(i) = 0._r8 - qpar(i) = 0._r8 - end do - - tp(:ncol,:) = t(:ncol,:) - qstp(:ncol,:) = q(:ncol,:) - hmn_lev(:ncol,:) = 0._r8 - - - -!!! Initialize tv and buoy for output. -!!! tv=tv : tpv=tpv : qstp=q : buoy=0. - tv(:ncol,:) = t(:ncol,:) *(1._r8+1.608_r8*q(:ncol,:))/ (1._r8+q(:ncol,:)) - tpv(:ncol,:) = tv(:ncol,:) - buoy(:ncol,:) = 0._r8 - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Mix the parcel over a certain dp or dz and take the launch level as the top level -! of this mixing region and the parcel properties as this mixed value -! Should be well mixed by other processes in the very near PBL. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - -if (lparcel_pbl) then - -! Vertical profile of MSE and pressure weighted of the same. - hmn_lev(:ncol,1:pver) = cp*t(:ncol,1:pver) + grav*z(:ncol,1:pver) + rl*q(:ncol,1:pver) - dp_lev(:ncol,1:pver) = pf(:ncol,2:pver+1)-pf(:ncol,1:pver) - hmn_zdp(:ncol,1:pver) = hmn_lev(:ncol,1:pver)*dp_lev(:ncol,1:pver) - q_zdp(:ncol,1:pver) = q(:ncol,1:pver)*dp_lev(:ncol,1:pver) - - -! Mix profile over vertical length scale of 0.5*PBLH. - - do i = 1,ncol ! Loop columns - do k = pver,msg + 1,-1 - - if (zi(i,k+1)<= parcel_dz(i)) then ! Has to be relative to near-surface layer center elevation - ipar = k - - if (k == pver) then ! Always at least the full depth of lowest model layer. - dp_zfrac = 1._r8 - else - ! Fraction of grid cell depth (mostly 1, except when parcel_ztop is in between levels. - dp_zfrac = min(1._r8,(parcel_dz(i)-zi(i,k+1))/(zi(i,k)-zi(i,k+1))) - end if - - parcel_hdp(i) = parcel_hdp(i)+hmn_zdp(i,k)*dp_zfrac ! Sum parcel profile up to a certain level. - parcel_qdp(i) = parcel_qdp(i)+q_zdp(i,k)*dp_zfrac ! Sum parcel profile up to a certain level. - parcel_dp(i) = parcel_dp(i)+dp_lev(i,k)*dp_zfrac ! SUM dp's for weighting of parcel_hdp - - end if - end do - hpar(i) = parcel_hdp(i)/parcel_dp(i) - qpar(i) = parcel_qdp(i)/parcel_dp(i) - mx(i) = ipar - end do - -else ! Default method finding level of MSE maximum (nlev sensitive though) - ! - ! set "launching" level(mx) to be at maximum moist static energy. - ! search for this level stops at planetary boundary layer top. - ! - do k = pver,msg + 1,-1 - do i = 1,ncol - hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k) - if (k >= nint(pblt(i)) .and. k <= lon(i) .and. hmn(i) > hmax(i)) then - hmax(i) = hmn(i) - mx(i) = k - end if - end do - end do - -end if ! Default method of determining parcel launch properties. - - - - - -! 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. - -if (lparcel_pbl) then - -! For parcel dilute need to invert hpar and qpar. -! Now need to supply ql(i) as it is mixed parcel version, just q(i,max(i)) in default - - do i = 1,ncol ! Initialise LCL variables. - lcl(i) = mx(i) - tl(i) = (hpar(i)-rl*qpar(i)-grav*parcel_ztop(i))/cp - ql(i) = qpar(i) - pl(i) = p(i,mx(i)) - end do - -else - - do i = 1,ncol - lcl(i) = mx(i) - tl(i) = t(i,mx(i)) - ql(i) = q(i,mx(i)) - pl(i) = p(i,mx(i)) - end do - -end if ! Mixed parcel properties - - - -! -! main buoyancy calculation. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! DILUTE PLUME CALCULATION USING ENTRAINING PLUME !!! -!!! RBN 9/9/04 !!! - - call parcel_dilute(lchnk, ncol, msg, mx, p, t, q, & - tpert, tp, tpv, qstp, pl, tl, ql, lcl, & - org, landfrac) - - -! 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,ncol - plge600(i) = pl(i).ge.600._r8 ! Just change to always allow buoy calculation. - end do - -! -! Main buoyancy calculation. -! - do k = pver,msg + 1,-1 - do i=1,ncol - if (k <= mx(i) .and. plge600(i)) then ! Define buoy from launch level to cloud top. - tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k)) - buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add ! +0.5K or not? - else - qstp(i,k) = q(i,k) - tp(i,k) = t(i,k) - tpv(i,k) = tv(i,k) - endif - end do - end do - - - -!------------------------------------------------------------------------------- - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - -! - do k = msg + 2,pver - do i = 1,ncol - if (k < lcl(i) .and. plge600(i)) then - if (buoy(i,k+1) > 0._r8 .and. buoy(i,k) <= 0._r8) then - knt(i) = min(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,num_cin - do k = msg + 1,pver - do i = 1,ncol - if (plge600(i) .and. k <= mx(i) .and. k > lelten(i,n)) then - capeten(i,n) = capeten(i,n) + rd*buoy(i,k)*log(pf(i,k+1)/pf(i,k)) - 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,num_cin - do i = 1,ncol - if (capeten(i,n) > cape(i)) then - cape(i) = capeten(i,n) - lel(i) = lelten(i,n) - end if - end do - end do -! -! put lower bound on cape for diagnostic purposes. -! - do i = 1,ncol - cape(i) = max(cape(i), 0._r8) - end do -! - return -end subroutine buoyan_dilute - -subroutine parcel_dilute (lchnk, ncol, msg, klaunch, p, t, q, & - tpert, tp, tpv, qstp, pl, tl, ql, lcl, & - org, landfrac) - -! Routine to determine -! 1. Tp - Parcel temperature -! 2. qstp - Saturated mixing ratio at the parcel temperature. - -!-------------------- -implicit none -!-------------------- - -integer, intent(in) :: lchnk -integer, intent(in) :: ncol -integer, intent(in) :: msg - -integer, intent(in), dimension(pcols) :: klaunch(pcols) - -real(r8), intent(in), dimension(pcols,pver) :: p -real(r8), intent(in), dimension(pcols,pver) :: t -real(r8), intent(in), dimension(pcols,pver) :: q -real(r8), intent(in), dimension(pcols) :: tpert ! PBL temperature perturbation. - -real(r8), intent(inout), dimension(pcols,pver) :: tp ! Parcel temp. -real(r8), intent(inout), dimension(pcols,pver) :: qstp ! Parcel water vapour (sat value above lcl). -real(r8), intent(inout), dimension(pcols) :: tl ! Actual temp of LCL. -real(r8), intent(inout), dimension(pcols) :: ql ! Actual humidity of LCL -real(r8), intent(inout), dimension(pcols) :: pl ! Actual pressure of LCL. - -integer, intent(inout), dimension(pcols) :: lcl ! Lifting condesation level (first model level with saturation). - -real(r8), intent(out), dimension(pcols,pver) :: tpv ! Define tpv within this routine. - -real(r8), pointer, dimension(:,:) :: org -real(r8), intent(in), dimension(pcols) :: landfrac -!-------------------- - -! Have to be careful as s is also dry static energy. - - -! 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(pcols,pver) ! Tempertaure of the entraining parcel. -real(r8) qtmix(pcols,pver) ! Total water of the entraining parcel. -real(r8) qsmix(pcols,pver) ! Saturated mixing ratio at the tmix. -real(r8) smix(pcols,pver) ! Entropy of the entraining parcel. -real(r8) xsh2o(pcols,pver) ! Precipitate lost from parcel. -real(r8) ds_xsh2o(pcols,pver) ! Entropy change due to loss of condensate. -real(r8) ds_freeze(pcols,pver) ! Entropy change sue to freezing of precip. -real(r8) dmpdz2d(pcols,pver) ! variable detrainment rate - -real(r8) mp(pcols) ! Parcel mass flux. -real(r8) qtp(pcols) ! Parcel total water. -real(r8) sp(pcols) ! Parcel entropy. - -real(r8) sp0(pcols) ! Parcel launch entropy. -real(r8) qtp0(pcols) ! Parcel launch total water. -real(r8) mp0(pcols) ! 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 " " ". -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) org2rkm, org2Tpert -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. - -!====================================================================== -! 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. -! - -if (zm_org) then - org2rkm = 10._r8 - org2Tpert = 0._r8 -endif -nit_lheat = 2 ! iterations for ds,dq changes from condensation freezing. -dmpdz=dmpdz_param ! Entrainment rate. (-ve for /m) -dmpdz_lnd=-1.e-3_r8 -!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. - -qtmix=0._r8 -smix=0._r8 - -qtenv = 0._r8 -senv = 0._r8 -tenv = 0._r8 -penv = 0._r8 - -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 - -! **** Begin loops **** - -do k = pver, msg+1, -1 - do i=1,ncol - -! Initialize parcel values at launch level. - - if (k == klaunch(i)) then - - if (lparcel_pbl) then ! Modifcations to parcel properties if lparcel_pbl set. - - qtp0(i) = ql(i) ! Parcel launch q (PBL mixed value). - sp0(i) = entropy(tl(i),pl(i),qtp0(i)) ! Parcel launch entropy could be a mixed parcel. - - else - - qtp0(i) = q(i,k) ! Parcel launch total water (assuming subsaturated) - sp0(i) = entropy(t(i,k),p(i,k),qtp0(i)) ! Parcel launch entropy. - - end if - - mp0(i) = 1._r8 ! Parcel launch relative mass (i.e. 1 parcel stays 1 parcel for dmpdp=0, undilute). - smix(i,k) = sp0(i) - qtmix(i,k) = qtp0(i) - tfguess = t(i,k) - rcall = 1 - call ientropy (rcall,i,lchnk,smix(i,k),p(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess) - end if - -! Entraining levels - - if (k < klaunch(i)) then - -! Set environmental values for this level. - - dp = (p(i,k)-p(i,k+1)) ! In -ve mb as p decreasing with height - difference between center of layers. - qtenv = 0.5_r8*(q(i,k)+q(i,k+1)) ! Total water of environment. - tenv = 0.5_r8*(t(i,k)+t(i,k+1)) - penv = 0.5_r8*(p(i,k)+p(i,k+1)) - - senv = entropy(tenv,penv,qtenv) ! Entropy of environment. - -! Determine fractional entrainment rate /pa given value /m. - - dpdz = -(penv*grav)/(rgas*tenv) ! in mb/m since p in mb. - dzdp = 1._r8/dpdz ! in m/mb - if (zm_org) then - dmpdz_mask = landfrac(i) * dmpdz_lnd + (1._r8 - landfrac(i)) * dmpdz - dmpdp = (dmpdz_mask/(1._r8+org(i,k)*org2rkm))*dzdp ! /mb Fractional entrainment - else - dmpdp = dmpdz*dzdp - endif - -! 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(i,k) = (sp0(i) + sp(i)) / (mp0(i) + mp(i)) - qtmix(i,k) = (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(i,k+1) - rcall = 2 - call ientropy(rcall,i,lchnk,smix(i,k),p(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess) - -! -! Determine if this is lcl of this column if qsmix <= qtmix. -! FIRST LEVEL where this happens on ascending. - - if (qsmix(i,k) <= qtmix(i,k) .and. qsmix(i,k+1) > qtmix(i,k+1)) then - lcl(i) = k - qxsk = qtmix(i,k) - qsmix(i,k) - qxskp1 = qtmix(i,k+1) - qsmix(i,k+1) - dqxsdp = (qxsk - qxskp1)/dp - pl(i) = p(i,k+1) - qxskp1/dqxsdp ! pressure level of actual lcl. - dsdp = (smix(i,k) - smix(i,k+1))/dp - dqtdp = (qtmix(i,k) - qtmix(i,k+1))/dp - slcl = smix(i,k+1) + dsdp* (pl(i)-p(i,k+1)) - qtlcl = qtmix(i,k+1) + dqtdp*(pl(i)-p(i,k+1)) - - tfguess = tmix(i,k) - rcall = 3 - call ientropy (rcall,i,lchnk,slcl,pl(i),qtlcl,tl(i),qslcl,tfguess) - -! 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 - -!!!!!!!!!!!!!!!!!!!!!!!!!!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 = pver, msg+1, -1 - do i=1,ncol - -! Initialize variables at k=klaunch - - if (k == klaunch(i)) then - -! Set parcel values at launch level assume no liquid water. - - tp(i,k) = tmix(i,k) - qstp(i,k) = q(i,k) - if (zm_org) then - tpv(i,k) = (tp(i,k) + (org2Tpert*org(i,k)+tpert(i))) * (1._r8+1.608_r8*qstp(i,k)) / (1._r8+qstp(i,k)) - else - tpv(i,k) = (tp(i,k) + tpert(i)) * (1._r8+1.608_r8*qstp(i,k)) / (1._r8+qstp(i,k)) - endif - - end if - - if (k < klaunch(i)) then - -! Initiaite 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(i,k) = max (0._r8, qtmix(i,k) - qsmix(i,k) - lwmax) - -! Contribution to ds from precip loss of condensate (Accumulated change from smix).(-ve) - - ds_xsh2o(i,k) = ds_xsh2o(i,k+1) - cpliq * log (tmix(i,k)/tfreez) * max(0._r8,(xsh2o(i,k)-xsh2o(i,k+1))) -! -! Entropy of freezing: latice times amount of water involved divided by T. -! - - if (tmix(i,k) <= tfreez+tscool .and. ds_freeze(i,k+1) == 0._r8) then ! One off freezing of condensate. - ds_freeze(i,k) = (latice/tmix(i,k)) * max(0._r8,qtmix(i,k)-qsmix(i,k)-xsh2o(i,k)) ! Gain of LH - end if - - if (tmix(i,k) <= tfreez+tscool .and. ds_freeze(i,k+1) /= 0._r8) then ! Continual freezing of additional condensate. - ds_freeze(i,k) = ds_freeze(i,k+1)+(latice/tmix(i,k)) * max(0._r8,(qsmix(i,k+1)-qsmix(i,k))) - end if - -! Adjust entropy and accordingly to sum of ds (be careful of signs). - - new_s = smix(i,k) + ds_xsh2o(i,k) + ds_freeze(i,k) - -! Adjust liquid water and accordingly to xsh2o. - - new_q = qtmix(i,k) - xsh2o(i,k) - -! Invert entropy to get updated Tmix and qsmix of parcel. - - tfguess = tmix(i,k) - rcall =4 - call ientropy (rcall,i,lchnk,new_s, p(i,k), new_q, tmix(i,k), qsmix(i,k), 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(i,k) = tmix(i,k) - -! tpv = tprho in the presence of condensate (i.e. when new_q > qsmix) - - if (new_q > qsmix(i,k)) then ! Super-saturated so condensate present - reduces buoyancy. - qstp(i,k) = qsmix(i,k) - else ! Just saturated/sub-saturated - no condensate virtual effects. - qstp(i,k) = new_q - end if - - if (zm_org) then - tpv(i,k) = (tp(i,k)+(org2Tpert*org(i,k)+tpert(i)))* (1._r8+1.608_r8*qstp(i,k)) / (1._r8+ new_q) - else - tpv(i,k) = (tp(i,k)+tpert(i))* (1._r8+1.608_r8*qstp(i,k)) / (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 = rl - (cpliq - cpwv)*(TK-tfreez) ! T IN CENTIGRADE - -call qsat_hPa(TK, p, est, qst) - -qv = min(qtot,qst) ! Partition qtot into vapor part only. -e = qv*p / (eps1 +qv) - -entropy = (cpres + qtot*cpliq)*log( TK/tfreez) - rgas*log( (p-e)/pref ) + & - L*qv/TK - qv*rh2o*log(qv/qst) - -end FUNCTION entropy - -! -!----------------------------------------------------------------------------------------- -SUBROUTINE ientropy (rcall,icol,lchnk,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 -! - - use phys_grid, only: get_rlon_p, get_rlat_p - - integer, intent(in) :: icol, lchnk, rcall - real(r8), intent(in) :: s, p, Tfg, qt - real(r8), intent(out) :: qst, T - real(r8) :: est, this_lat,this_lon - 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 - this_lat = get_rlat_p(lchnk, icol)*57.296_r8 - this_lon = get_rlon_p(lchnk, icol)*57.296_r8 - write(iulog,*) '*** ZM_CONV: IENTROPY: Failed and about to exit, info follows ****' - write(iulog,100) 'ZM_CONV: IENTROPY. Details: call#,lchnk,icol= ',rcall,lchnk,icol, & - ' lat: ',this_lat,' lon: ',this_lon, & - ' P(mb)= ', p, ' Tfg(K)= ', Tfg, ' qt(g/kg) = ', 1000._r8*qt, & - ' qst(g/kg) = ', 1000._r8*qst,', s(J/kg) = ',s - 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 - -end module zm_conv diff --git a/src/physics/cam/zm_conv_intr.F90 b/src/physics/cam/zm_conv_intr.F90 index 48e8d5e932..d559ce4be4 100644 --- a/src/physics/cam/zm_conv_intr.F90 +++ b/src/physics/cam/zm_conv_intr.F90 @@ -8,11 +8,13 @@ module zm_conv_intr ! January 2010 modified by J. Kay to add COSP simulator fields to physics buffer !--------------------------------------------------------------------------------- use shr_kind_mod, only: r8=>shr_kind_r8 - use physconst, only: cpair + use physconst, only: cpair, epsilo, gravit, latvap, tmelt, rair use ppgrid, only: pver, pcols, pverp, begchunk, endchunk - use zm_conv, only: zm_conv_evap, zm_convr, convtran, momtran - - use zm_microphysics, only: zm_aero_t, zm_conv_t + use zm_conv_evap, only: zm_conv_evap_run + use zm_convr, only: zm_convr_init, zm_convr_run + use zm_conv_convtran, only: zm_conv_convtran_run + use zm_conv_momtran, only: zm_conv_momtran_run + use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num, rad_cnst_get_aer_mmr, & rad_cnst_get_aer_props, rad_cnst_get_mode_props !, & use ndrop_bam, only: ndrop_bam_init @@ -36,7 +38,7 @@ module zm_conv_intr zm_conv_tend, &! return tendencies zm_conv_tend_2 ! return tendencies - public :: zmconv_microp + public zmconv_ke, zmconv_ke_lnd, zmconv_org ! needed by convect_shallow integer ::& ! indices for fields in the physics buffer zm_mu_idx, & @@ -73,7 +75,6 @@ module zm_conv_intr ! before the convection top and CAPE calculations are completed. logical :: zmconv_org ! Parameterization for sub-grid scale convective organization for the ZM deep ! convective scheme based on Mapes and Neale (2011) - logical :: zmconv_microp = .false. ! switch for microphysics real(r8) :: zmconv_dmpdz = unset_r8 ! Parcel fractional mass entrainment rate real(r8) :: zmconv_tiedke_add = unset_r8 ! Convective parcel temperature perturbation real(r8) :: zmconv_capelmt = unset_r8 ! Triggering thereshold for ZM convection @@ -92,8 +93,6 @@ module zm_conv_intr integer :: nmodes integer :: nbulk - type(zm_aero_t), allocatable :: aero(:) ! object contains information about the aerosols - !========================================================================================= contains !========================================================================================= @@ -156,15 +155,7 @@ subroutine zm_conv_register ! convective mass fluxes call pbuf_add_field('CMFMC_DP', 'physpkg', dtype_r8, (/pcols,pverp/), mconzm_idx) - if (zmconv_microp) then - ! Only add the number conc fields if the microphysics is active. - - ! detrained convective cloud water num concen. - call pbuf_add_field('DNLFZM', 'physpkg', dtype_r8, (/pcols,pver/), dnlfzm_idx) - ! detrained convective cloud ice num concen. - call pbuf_add_field('DNIFZM', 'physpkg', dtype_r8, (/pcols,pver/), dnifzm_idx) - end if - +!CACNOTE - Is zm_org really a constituent or was it just a handy structure to use for an allocatable which persists in the run? if (zmconv_org) then call cnst_add('ZM_ORG',0._r8,0._r8,0._r8,ixorg,longname='organization parameter') endif @@ -187,7 +178,7 @@ subroutine zm_conv_readnl(nlfile) namelist /zmconv_nl/ zmconv_c0_lnd, zmconv_c0_ocn, zmconv_num_cin, & zmconv_ke, zmconv_ke_lnd, zmconv_org, & - zmconv_momcu, zmconv_momcd, zmconv_microp, & + zmconv_momcu, zmconv_momcd, & zmconv_dmpdz, zmconv_tiedke_add, zmconv_capelmt, & zmconv_parcel_pbl, zmconv_tau !----------------------------------------------------------------------------- @@ -224,8 +215,6 @@ subroutine zm_conv_readnl(nlfile) if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_momcd") call mpi_bcast(zmconv_org, 1, mpi_logical, masterprocid, mpicom, ierr) if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_org") - call mpi_bcast(zmconv_microp, 1, mpi_logical, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_microp") call mpi_bcast(zmconv_dmpdz, 1, mpi_real8, masterprocid, mpicom, ierr) if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_dmpdz") call mpi_bcast(zmconv_tiedke_add, 1, mpi_real8, masterprocid, mpicom, ierr) @@ -233,7 +222,7 @@ subroutine zm_conv_readnl(nlfile) call mpi_bcast(zmconv_capelmt, 1, mpi_real8, masterprocid, mpicom, ierr) if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_capelmt") call mpi_bcast(zmconv_parcel_pbl, 1, mpi_logical, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_parcel_pbl") + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_parcel_pbl") call mpi_bcast(zmconv_tau, 1, mpi_real8, masterprocid, mpicom, ierr) if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_tau") @@ -249,7 +238,7 @@ subroutine zm_conv_init(pref_edge) use cam_history, only: addfld, add_default, horiz_only use ppgrid, only: pcols, pver - use zm_conv, only: zm_convi + use zm_convr, only: zm_convr_init use pmgrid, only: plev,plevp use spmd_utils, only: masterproc use phys_control, only: phys_deepconv_pbl, phys_getopts, cam_physpkg_is @@ -259,6 +248,8 @@ subroutine zm_conv_init(pref_edge) real(r8),intent(in) :: pref_edge(plevp) ! reference pressures at interfaces + character(len=512) :: errmsg + integer :: errflg logical :: no_deep_pbl ! if true, no deep convection in PBL integer limcnv ! top interface level limit for convection @@ -268,12 +259,6 @@ subroutine zm_conv_init(pref_edge) ! liquid budgets. integer :: history_budget_histfile_num ! output history file number for budget fields -! Allocate the basic aero structure outside the zmconv_microp logical -! This allows the aero structure to be passed -! Note that all of the arrays inside this structure are conditionally allocated - - allocate(aero(begchunk:endchunk)) - ! ! Register fields with the output buffer ! @@ -344,10 +329,6 @@ subroutine zm_conv_init(pref_edge) call add_default('ZMMTT ', history_budget_histfile_num, ' ') end if - if (zmconv_microp) then - call add_default ('DIFZM', 1, ' ') - call add_default ('DLFZM', 1, ' ') - end if ! ! Limit deep convection to regions below 40 mb ! Note this calculation is repeated in the shallow convection interface @@ -371,16 +352,16 @@ subroutine zm_conv_init(pref_edge) end if no_deep_pbl = phys_deepconv_pbl() - call zm_convi(limcnv,zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & +!CACNOTE - Need to check errflg and report errors + call zm_convr_init(cpair, epsilo, gravit, latvap, tmelt, rair, & + limcnv,zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & zmconv_momcu, zmconv_momcd, zmconv_num_cin, zmconv_org, & - zmconv_microp, no_deep_pbl, zmconv_tiedke_add, & - zmconv_capelmt, zmconv_dmpdz,zmconv_parcel_pbl, zmconv_tau) + no_deep_pbl, zmconv_tiedke_add, & + zmconv_capelmt, zmconv_dmpdz,zmconv_parcel_pbl, zmconv_tau, errmsg, errflg) cld_idx = pbuf_get_index('CLD') fracis_idx = pbuf_get_index('FRACIS') - if (zmconv_microp) call zm_conv_micro_init() - end subroutine zm_conv_init !========================================================================================= !subroutine zm_conv_tend(state, ptend, tdt) @@ -402,7 +383,8 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & use physics_buffer, only : pbuf_get_field, physics_buffer_desc, pbuf_old_tim_idx use constituents, only: pcnst, cnst_get_ind, cnst_is_convtran1 use check_energy, only: check_energy_chng - use physconst, only: gravit + use physconst, only: gravit, latice, latvap, tmelt, cpwv, cpliq, rh2o + use phys_control, only: cam_physpkg_is ! Arguments @@ -426,8 +408,8 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ! Local variables - - type(zm_conv_t) :: conv + character(len=512) :: errmsg + integer :: errflg integer :: i,k,l,m integer :: ilon ! global longitude index of a column @@ -504,7 +486,10 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & integer :: ii real(r8),pointer :: zm_org2d(:,:) - real(r8),pointer :: orgt(:,:), org(:,:) + real(r8),allocatable :: orgt_alloc(:,:), org_alloc(:,:) + + real(r8) :: zm_org2d_ncol(state%ncol,pver) + real(r8) :: orgt_ncol(state%ncol,pver), org_ncol(state%ncol,pver) logical :: lq(pcnst) @@ -515,57 +500,6 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ncol = state%ncol nstep = get_nstep() - if (zmconv_microp) then - allocate( & - conv%qi(pcols,pver), & - conv%qliq(pcols,pver), & - conv%qice(pcols,pver), & - conv%wu(pcols,pver), & - conv%sprd(pcols,pver), & - conv%qrain(pcols,pver), & - conv%qsnow(pcols,pver), & - conv%qnl(pcols,pver), & - conv%qni(pcols,pver), & - conv%qnr(pcols,pver), & - conv%qns(pcols,pver), & - conv%frz(pcols,pver), & - conv%autolm(pcols,pver), & - conv%accrlm(pcols,pver), & - conv%bergnm(pcols,pver), & - conv%fhtimm(pcols,pver), & - conv%fhtctm(pcols,pver), & - conv%fhmlm (pcols,pver), & - conv%hmpim (pcols,pver), & - conv%accslm(pcols,pver), & - conv%dlfm (pcols,pver), & - conv%autoln(pcols,pver), & - conv%accrln(pcols,pver), & - conv%bergnn(pcols,pver), & - conv%fhtimn(pcols,pver), & - conv%fhtctn(pcols,pver), & - conv%fhmln (pcols,pver), & - conv%accsln(pcols,pver), & - conv%activn(pcols,pver), & - conv%dlfn (pcols,pver), & - conv%autoim(pcols,pver), & - conv%accsim(pcols,pver), & - conv%difm (pcols,pver), & - conv%nuclin(pcols,pver), & - conv%autoin(pcols,pver), & - conv%accsin(pcols,pver), & - conv%hmpin (pcols,pver), & - conv%difn (pcols,pver), & - conv%cmel (pcols,pver), & - conv%cmei (pcols,pver), & - conv%trspcm(pcols,pver), & - conv%trspcn(pcols,pver), & - conv%trspim(pcols,pver), & - conv%trspin(pcols,pver), & - conv%lambdadpcu(pcols,pver), & - conv%mudpcu(pcols,pver), & - conv%dcape(pcols) ) - end if - ftem = 0._r8 mu_out(:,:) = 0._r8 md_out(:,:) = 0._r8 @@ -578,7 +512,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & if (zmconv_org) then lq(ixorg) = .TRUE. endif - call physics_ptend_init(ptend_loc, state%psetcols, 'zm_convr', ls=.true., lq=lq)! initialize local ptend type + call physics_ptend_init(ptend_loc, state%psetcols, 'zm_convr_run', ls=.true., lq=lq)! initialize local ptend type ! ! Associate pointers with physics buffer fields @@ -608,66 +542,70 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call pbuf_get_field(pbuf, difzm_idx, dif) call pbuf_get_field(pbuf, mconzm_idx, mconzm) - if (zmconv_microp) then - call pbuf_get_field(pbuf, dnlfzm_idx, dnlf) - call pbuf_get_field(pbuf, dnifzm_idx, dnif) - else - allocate(dnlf(pcols,pver), dnif(pcols,pver)) - end if - - if (zmconv_microp) then - - if (nmodes > 0) then - - ! Associate pointers with the modes and species that affect the climate - ! (list 0) - - do m = 1, nmodes - call rad_cnst_get_mode_num(0, m, 'a', state, pbuf, aero(lchnk)%num_a(m)%val) - call pbuf_get_field(pbuf, dgnum_idx, aero(lchnk)%dgnum(m)%val, start=(/1,1,m/), kount=(/pcols,pver,1/)) - - do l = 1, aero(lchnk)%nspec(m) - call rad_cnst_get_aer_mmr(0, m, l, 'a', state, pbuf, aero(lchnk)%mmr_a(l,m)%val) - end do - end do - - else if (nbulk > 0) then - - ! Associate pointers with the bulk aerosols that affect the climate - ! (list 0) - - do m = 1, nbulk - call rad_cnst_get_aer_mmr(0, m, state, pbuf, aero(lchnk)%mmr_bulk(m)%val) - end do - - end if - end if + allocate(dnlf(pcols,pver), dnif(pcols,pver)) ! ! Begin with Zhang-McFarlane (1996) convection parameterization ! - call t_startf ('zm_convr') + call t_startf ('zm_convr_run') if (zmconv_org) then allocate(zm_org2d(pcols,pver)) - org => state%q(:,:,ixorg) - orgt => ptend_loc%q(:,:,ixorg) + allocate(org_alloc(ncol,pver)) + allocate(orgt_alloc(ncol,pver)) + org_ncol(:ncol,:) = state%q(1:ncol,:,ixorg) endif - call zm_convr( lchnk ,ncol , & - state%t ,state%q(:,:,1), prec ,jctop ,jcbot , & - pblh ,state%zm ,state%phis ,state%zi ,ptend_loc%q(:,:,1) , & - ptend_loc%s , state%pmid ,state%pint ,state%pdel , & - .5_r8*ztodt ,mcon ,cme , cape, & - tpert ,dlf ,pflx ,zdu ,rprd , & - mu, md, du, eu, ed, & - dp, dsubcld, jt, maxg, ideep, & - ql, rliq, landfrac, & - org, orgt, zm_org2d, & - dif, dnlf, dnif, conv, & - aero(lchnk), rice) +!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + ptend_loc%q(:,:,1) = 0._r8 + ptend_loc%s(:,:) = 0._r8 + mcon(:,:) = 0._r8 + dlf(:,:) = 0._r8 + pflx(:,:) = 0._r8 + cme(:,:) = 0._r8 + cape(:) = 0._r8 + zdu(:,:) = 0._r8 + rprd(:,:) = 0._r8 + dif(:,:) = 0._r8 + dnlf(:,:) = 0._r8 + dnif(:,:) = 0._r8 + mu(:,:) = 0._r8 + eu(:,:) = 0._r8 + du(:,:) = 0._r8 + md(:,:) = 0._r8 + ed(:,:) = 0._r8 + dp(:,:) = 0._r8 + dsubcld(:) = 0._r8 + jctop(:) = 0._r8 + jcbot(:) = 0._r8 + prec(:) = 0._r8 + rliq(:) = 0._r8 + rice(:) = 0._r8 + ideep(:) = 0._r8 +!REMOVECAM_END + +!CACNOTE - Need to check errflg and report errors + call zm_convr_run(ncol, pver, & + pverp, gravit, latice, cpwv, cpliq, rh2o, & + state%t(:ncol,:), state%q(:ncol,:,1), prec(:ncol), jctop(:ncol), jcbot(:ncol), & + pblh(:ncol), state%zm(:ncol,:), state%phis, state%zi(:ncol,:), ptend_loc%q(:ncol,:,1), & + ptend_loc%s(:ncol,:), state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), & + .5_r8*ztodt, mcon(:ncol,:), cme(:ncol,:), cape(:ncol), & + tpert(:ncol), dlf(:ncol,:), pflx(:ncol,:), zdu(:ncol,:), rprd(:ncol,:), & + mu(:ncol,:), md(:ncol,:), du(:ncol,:), eu(:ncol,:), ed(:ncol,:), & + dp(:ncol,:), dsubcld(:ncol), jt(:ncol), maxg(:ncol), ideep(:ncol), & + ql(:ncol,:), rliq(:ncol), landfrac(:ncol), & + org_ncol(:,:), orgt_ncol(:,:), zm_org2d_ncol(:,:), & + dif(:ncol,:), dnlf(:ncol,:), dnif(:ncol,:), & + rice(:ncol), errmsg, errflg) + + if (zmconv_org) then + ptend_loc%q(:,:,ixorg)=orgt_ncol(:ncol,:) + zm_org2d(:ncol,:) = zm_org2d_ncol(:ncol,:) + endif lengath = count(ideep > 0) + if (lengath > ncol) lengath = ncol ! should not happen, but force it to not be larger than ncol for safety sake call outfld('CAPE', cape, pcols, lchnk) ! RBN - CAPE output ! @@ -702,13 +640,11 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair call outfld('ZMDT ',ftem ,pcols ,lchnk ) call outfld('ZMDQ ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) - call t_stopf ('zm_convr') + call t_stopf ('zm_convr_run') call outfld('DIFZM' ,dif ,pcols, lchnk) call outfld('DLFZM' ,dlf ,pcols, lchnk) - if (zmconv_microp) call zm_conv_micro_outfld(conv, dnif, dnlf, lchnk, ncol) - pcont(:ncol) = state%ps(:ncol) pconb(:ncol) = state%ps(:ncol) do i = 1,lengath @@ -735,9 +671,9 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & if (zmconv_org) then lq(ixorg) = .TRUE. endif - call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_evap', ls=.true., lq=lq) + call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_evap_run', ls=.true., lq=lq) - call t_startf ('zm_conv_evap') + call t_startf ('zm_conv_evap_run') ! ! Determine the phase of the precipitation produced and add latent heat of fusion ! Evaporate some of the precip directly into the environment (Sundqvist) @@ -751,13 +687,20 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call pbuf_get_field(pbuf, dp_cldice_idx, dp_cldice ) dp_cldliq(:ncol,:) = 0._r8 dp_cldice(:ncol,:) = 0._r8 - - call zm_conv_evap(state1%ncol,state1%lchnk, & - state1%t,state1%pmid,state1%pdel,state1%q(:pcols,:pver,1), & - landfrac, & - ptend_loc%s, tend_s_snwprd, tend_s_snwevmlt, ptend_loc%q(:pcols,:pver,1), & - rprd, cld, ztodt, & - prec, snow, ntprprd, ntsnprd , flxprec, flxsnow, conv%sprd) +!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + flxprec(:,:) = 0._r8 + flxsnow(:,:) = 0._r8 + snow(:) = 0._r8 +!REMOVECAM_END + + call zm_conv_evap_run(state1%ncol, pver, pverp, & + gravit, latice, latvap, tmelt, & + cpair, zmconv_ke, zmconv_ke_lnd, zmconv_org, & + state1%t(:ncol,:),state1%pmid(:ncol,:),state1%pdel(:ncol,:),state1%q(:ncol,:pver,1), & + landfrac(:ncol), & + ptend_loc%s(:ncol,:), tend_s_snwprd(:ncol,:), tend_s_snwevmlt(:ncol,:), ptend_loc%q(:ncol,:pver,1), & + rprd(:ncol,:), cld(:ncol,:), ztodt, & + prec(:ncol), snow(:ncol), ntprprd(:ncol,:), ntsnprd(:ncol,:), flxprec(:ncol,:), flxsnow(:ncol,:) ) evapcdp(:ncol,:pver) = ptend_loc%q(:ncol,:pver,1) @@ -768,7 +711,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & endif ! -! Write out variables from zm_conv_evap +! Write out variables from zm_conv_evap_run ! ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair call outfld('EVAPTZM ',ftem ,pcols ,lchnk ) @@ -786,7 +729,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call outfld('PRECCDZM ',prec, pcols ,lchnk ) - call t_stopf ('zm_conv_evap') + call t_stopf ('zm_conv_evap_run') call outfld('PRECZ ', prec , pcols, lchnk) @@ -801,7 +744,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & if ( .not. cam_physpkg_is('cam3')) then - call physics_ptend_init(ptend_loc, state1%psetcols, 'momtran', ls=.true., lu=.true., lv=.true.) + call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_momtran_run', ls=.true., lu=.true., lv=.true.) winds(:ncol,:pver,1) = state1%u(:ncol,:pver) winds(:ncol,:pver,2) = state1%v(:ncol,:pver) @@ -809,13 +752,20 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & l_windt(1) = .true. l_windt(2) = .true. - call t_startf ('momtran') - call momtran (lchnk, ncol, & - l_windt,winds, 2, mu, md, & - du, eu, ed, dp, dsubcld, & - jt, maxg, ideep, 1, lengath, & - nstep, wind_tends, pguall, pgdall, icwu, icwd, ztodt, seten ) - call t_stopf ('momtran') + call t_startf ('zm_conv_momtran_run') + +!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + wind_tends(:,:,:) = 0._r8 +!REMOVECAM_END + + call zm_conv_momtran_run (ncol, pver, pverp, & + l_windt,winds(:ncol,:,:), 2, mu(:ncol,:), md(:ncol,:), & + zmconv_momcu, zmconv_momcd, & + du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & + jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & + nstep, wind_tends(:ncol,:,:), pguall(:ncol,:,:), pgdall(:ncol,:,:), & + icwu(:ncol,:,:), icwd(:ncol,:,:), ztodt, seten(:ncol,:) ) + call t_stopf ('zm_conv_momtran_run') ptend_loc%u(:ncol,:pver) = wind_tends(:ncol,:pver,1) ptend_loc%v(:ncol,:pver) = wind_tends(:ncol,:pver,2) @@ -863,11 +813,16 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & fake_dpdry(:,:) = 0._r8 call t_startf ('convtran1') - call convtran (lchnk, & - ptend_loc%lq,state1%q, pcnst, mu, md, & - du, eu, ed, dp, dsubcld, & - jt,maxg, ideep, 1, lengath, & - nstep, fracis, ptend_loc%q, fake_dpdry, ztodt) + +!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + ptend_loc%q(:,:,:) = 0._r8 +!REMOVECAM_END + + call zm_conv_convtran_run (ncol, pver, & + ptend_loc%lq,state1%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & + du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & + jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & + nstep, fracis(:ncol,:,:), ptend_loc%q(:ncol,:,:), fake_dpdry(:ncol,:), ztodt) call t_stopf ('convtran1') call outfld('ZMDICE ',ptend_loc%q(1,1,ixcldice) ,pcols ,lchnk ) @@ -883,61 +838,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & deallocate(zm_org2d) end if - if (zmconv_microp) then - deallocate( & - conv%qi, & - conv%qliq, & - conv%qice, & - conv%wu, & - conv%sprd, & - conv%qrain, & - conv%qsnow, & - conv%qnl, & - conv%qni, & - conv%qnr, & - conv%qns, & - conv%frz, & - conv%autolm, & - conv%accrlm, & - conv%bergnm, & - conv%fhtimm, & - conv%fhtctm, & - conv%fhmlm , & - conv%hmpim , & - conv%accslm, & - conv%dlfm , & - conv%autoln, & - conv%accrln, & - conv%bergnn, & - conv%fhtimn, & - conv%fhtctn, & - conv%fhmln , & - conv%accsln, & - conv%activn, & - conv%dlfn , & - conv%autoim, & - conv%accsim, & - conv%difm , & - conv%nuclin, & - conv%autoin, & - conv%accsin, & - conv%hmpin , & - conv%difn , & - conv%cmel , & - conv%cmei , & - conv%trspcm, & - conv%trspcn, & - conv%trspim, & - conv%trspin, & - conv%lambdadpcu, & - conv%mudpcu, & - conv%dcape ) - - else - - deallocate(dnlf, dnif) - - end if + deallocate(dnlf, dnif) end subroutine zm_conv_tend !========================================================================================= @@ -962,6 +863,7 @@ subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) integer :: i, lchnk, istat integer :: lengath ! number of columns with deep convection integer :: nstep + integer :: ncol real(r8), dimension(pcols,pver) :: dpdry @@ -994,11 +896,14 @@ subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) call pbuf_get_field(pbuf, zm_maxg_idx, maxg) call pbuf_get_field(pbuf, zm_ideep_idx, ideep) - lengath = count(ideep > 0) lchnk = state%lchnk + ncol = state%ncol nstep = get_nstep() + lengath = count(ideep > 0) + if (lengath > ncol) lengath = ncol ! should not happen, but force it to not be larger than ncol for safety sake + if (any(ptend%lq(:))) then ! initialize dpdry for call to convtran ! it is used for tracers of dry mixing ratio type @@ -1008,11 +913,16 @@ subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) end do call t_startf ('convtran2') - call convtran (lchnk, & - ptend%lq,state%q, pcnst, mu, md, & - du, eu, ed, dp, dsubcld, & - jt, maxg, ideep, 1, lengath, & - nstep, fracis, ptend%q, dpdry, ztodt) + +!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + ptend%q(:,:,:) = 0._r8 +!REMOVECAM_END + + call zm_conv_convtran_run (ncol, pver, & + ptend%lq,state%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & + du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & + jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & + nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:), ztodt) call t_stopf ('convtran2') end if @@ -1020,384 +930,5 @@ end subroutine zm_conv_tend_2 !========================================================================================= -subroutine zm_conv_micro_init() - - use cam_history, only: addfld, add_default, horiz_only - use ppgrid, only: pcols, pver - use pmgrid, only: plev,plevp - use phys_control, only: cam_physpkg_is - use physics_buffer, only: pbuf_get_index - use zm_microphysics, only: zm_mphyi - - implicit none - - integer :: i - - ! - ! Register fields with the output buffer - ! - call addfld ('ICIMRDP', (/ 'lev' /), 'A','kg/kg', 'Deep Convection in-cloud ice mixing ratio ') - call addfld ('CLDLIQZM',(/ 'lev' /), 'A','g/m3' ,'Cloud liquid water - ZM convection') - call addfld ('CLDICEZM',(/ 'lev' /), 'A','g/m3' ,'Cloud ice water - ZM convection') - call addfld ('CLIQSNUM',(/ 'lev' /), 'A','1' ,'Cloud liquid water sample number - ZM convection') - call addfld ('CICESNUM',(/ 'lev' /), 'A','1' ,'Cloud ice water sample number - ZM convection') - call addfld ('QRAINZM' ,(/ 'lev' /), 'A','g/m3' ,'rain water - ZM convection') - call addfld ('QSNOWZM' ,(/ 'lev' /), 'A','g/m3' ,'snow - ZM convection') - call addfld ('CRAINNUM',(/ 'lev' /), 'A','1' ,'Cloud rain water sample number - ZM convection') - call addfld ('CSNOWNUM',(/ 'lev' /), 'A','1' ,'Cloud snow sample number - ZM convection') - - call addfld ('DNIFZM' ,(/ 'lev' /), 'A','1/kg/s ' ,'Detrained ice water num concen from ZM convection') - call addfld ('DNLFZM' ,(/ 'lev' /), 'A','1/kg/s ' ,'Detrained liquid water num concen from ZM convection') - call addfld ('WUZM' ,(/ 'lev' /), 'A','m/s' ,'vertical velocity - ZM convection') - call addfld ('WUZMSNUM',(/ 'lev' /), 'A','1' ,'vertical velocity sample number - ZM convection') - - call addfld ('QNLZM',(/ 'lev' /), 'A','1/m3' ,'Cloud liquid water number concen - ZM convection') - call addfld ('QNIZM',(/ 'lev' /), 'A','1/m3' ,'Cloud ice number concen - ZM convection') - call addfld ('QNRZM',(/ 'lev' /), 'A','1/m3' ,'Cloud rain water number concen - ZM convection') - call addfld ('QNSZM',(/ 'lev' /), 'A','1/m3' ,'Cloud snow number concen - ZM convection') - - call addfld ('FRZZM',(/ 'lev' /), 'A','1/s' ,'mass tendency due to freezing - ZM convection') - - call addfld ('AUTOL_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to autoconversion of droplets to rain') - call addfld ('ACCRL_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to accretion of droplets by rain') - call addfld ('BERGN_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to Bergeron process') - call addfld ('FHTIM_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to immersion freezing') - call addfld ('FHTCT_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to contact freezing') - call addfld ('FHML_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to homogeneous freezing of droplet') - call addfld ('HMPI_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to HM process') - call addfld ('ACCSL_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to accretion of droplet by snow') - call addfld ('DLF_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to detrainment of droplet') - call addfld ('COND_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to condensation') - - call addfld ('AUTOL_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to autoconversion of droplets to rain') - call addfld ('ACCRL_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to accretion of droplets by rain') - call addfld ('BERGN_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to Bergeron process') - call addfld ('FHTIM_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to immersion freezing') - call addfld ('FHTCT_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to contact freezing') - call addfld ('FHML_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to homogeneous freezing of droplet') - call addfld ('ACCSL_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to accretion of droplet by snow') - call addfld ('ACTIV_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to droplets activation') - call addfld ('DLF_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to detrainment of droplet') - - call addfld ('AUTOI_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to autoconversion of ice to snow') - call addfld ('ACCSI_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to accretion of ice by snow') - call addfld ('DIF_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to detrainment of cloud ice') - call addfld ('DEPOS_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to deposition') - - call addfld ('NUCLI_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to ice nucleation') - call addfld ('AUTOI_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to autoconversion of ice to snow') - call addfld ('ACCSI_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to accretion of ice by snow') - call addfld ('HMPI_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to HM process') - call addfld ('DIF_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to detrainment of cloud ice') - - call addfld ('TRSPC_M' ,(/ 'lev' /), 'A','kg/kg/m','mass tendency of droplets due to convective transport') - call addfld ('TRSPC_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency of droplets due to convective transport') - call addfld ('TRSPI_M' ,(/ 'lev' /), 'A','kg/kg/m','mass tendency of ice crystal due to convective transport') - call addfld ('TRSPI_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency of ice crystal due to convective transport') - - - call add_default ('CLDLIQZM', 1, ' ') - call add_default ('CLDICEZM', 1, ' ') - call add_default ('CLIQSNUM', 1, ' ') - call add_default ('CICESNUM', 1, ' ') - call add_default ('DNIFZM', 1, ' ') - call add_default ('DNLFZM', 1, ' ') - call add_default ('WUZM', 1, ' ') - call add_default ('QRAINZM', 1, ' ') - call add_default ('QSNOWZM', 1, ' ') - call add_default ('CRAINNUM', 1, ' ') - call add_default ('CSNOWNUM', 1, ' ') - call add_default ('QNLZM', 1, ' ') - call add_default ('QNIZM', 1, ' ') - call add_default ('QNRZM', 1, ' ') - call add_default ('QNSZM', 1, ' ') - call add_default ('FRZZM', 1, ' ') - - ! Initialization for the microphysics - - call zm_mphyi() - - ! Initialize the aerosol object with data from the modes/species - ! affecting climate, - ! i.e., the list index is hardcoded to 0. - - call rad_cnst_get_info(0, nmodes=nmodes, naero=nbulk) - - - do i = begchunk, endchunk - call zm_aero_init(nmodes, nbulk, aero(i)) - end do - - if (nmodes > 0) then - - dgnum_idx = pbuf_get_index('DGNUM') - - else if (nbulk > 0 .and. cam_physpkg_is('cam4')) then - - ! This call is needed to allow running the ZM microphysics with the - ! cam4 physics package. - call ndrop_bam_init() - - end if - - end subroutine zm_conv_micro_init - - - subroutine zm_aero_init(nmodes, nbulk, aero) - - use pmgrid, only: plev,plevp - - ! Initialize the zm_aero_t object for modal aerosols - - integer, intent(in) :: nmodes - integer, intent(in) :: nbulk - type(zm_aero_t), intent(out) :: aero - - integer :: iaer, l, m - integer :: nspecmx ! max number of species in a mode - - character(len=20), allocatable :: aername(:) - character(len=32) :: str32 - character(len=*), parameter :: routine = 'zm_conv_init' - - real(r8) :: sigmag, dgnumlo, dgnumhi - real(r8) :: alnsg - !---------------------------------------------------------------------------------- - - aero%nmodes = nmodes - aero%nbulk = nbulk - - if (nmodes > 0) then - - ! Initialize the modal aerosol information - - aero%scheme = 'modal' - - ! Get number of species in each mode, and find max. - allocate(aero%nspec(aero%nmodes)) - nspecmx = 0 - do m = 1, aero%nmodes - - call rad_cnst_get_info(0, m, nspec=aero%nspec(m), mode_type=str32) - - nspecmx = max(nspecmx, aero%nspec(m)) - - ! save mode index for specified mode types - select case (trim(str32)) - case ('accum') - aero%mode_accum_idx = m - case ('aitken') - aero%mode_aitken_idx = m - case ('coarse') - aero%mode_coarse_idx = m - end select - - end do - - ! Check that required mode types were found - if (aero%mode_accum_idx == -1 .or. aero%mode_aitken_idx == -1 .or. aero%mode_coarse_idx == -1) then - write(iulog,*) routine//': ERROR required mode type not found - mode idx:', & - aero%mode_accum_idx, aero%mode_aitken_idx, aero%mode_coarse_idx - call endrun(routine//': ERROR required mode type not found') - end if - - ! find indices for the dust and seasalt species in the coarse mode - do l = 1, aero%nspec(aero%mode_coarse_idx) - call rad_cnst_get_info(0, aero%mode_coarse_idx, l, spec_type=str32) - select case (trim(str32)) - case ('dust') - aero%coarse_dust_idx = l - case ('seasalt') - aero%coarse_nacl_idx = l - end select - end do - ! Check that required modal specie types were found - if (aero%coarse_dust_idx == -1 .or. aero%coarse_nacl_idx == -1) then - write(iulog,*) routine//': ERROR required mode-species type not found - indicies:', & - aero%coarse_dust_idx, aero%coarse_nacl_idx - call endrun(routine//': ERROR required mode-species type not found') - end if - - allocate( & - aero%num_a(nmodes), & - aero%mmr_a(nspecmx,nmodes), & - aero%numg_a(pcols,pver,nmodes), & - aero%mmrg_a(pcols,pver,nspecmx,nmodes), & - aero%voltonumblo(nmodes), & - aero%voltonumbhi(nmodes), & - aero%specdens(nspecmx,nmodes), & - aero%spechygro(nspecmx,nmodes), & - aero%dgnum(nmodes), & - aero%dgnumg(pcols,pver,nmodes) ) - - - do m = 1, nmodes - - ! Properties of modes - call rad_cnst_get_mode_props(0, m, & - sigmag=sigmag, dgnumlo=dgnumlo, dgnumhi=dgnumhi) - - alnsg = log(sigmag) - aero%voltonumblo(m) = 1._r8 / ( (pi/6._r8)*(dgnumlo**3._r8)*exp(4.5_r8*alnsg**2._r8) ) - aero%voltonumbhi(m) = 1._r8 / ( (pi/6._r8)*(dgnumhi**3._r8)*exp(4.5_r8*alnsg**2._r8) ) - - ! save sigmag of aitken mode - if (m == aero%mode_aitken_idx) aero%sigmag_aitken = sigmag - - ! Properties of modal species - do l = 1, aero%nspec(m) - call rad_cnst_get_aer_props(0, m, l, density_aer=aero%specdens(l,m), & - hygro_aer=aero%spechygro(l,m)) - end do - end do - - else if (nbulk > 0) then - - aero%scheme = 'bulk' - - ! Props needed for BAM number concentration calcs. - allocate( & - aername(nbulk), & - aero%num_to_mass_aer(nbulk), & - aero%mmr_bulk(nbulk), & - aero%mmrg_bulk(pcols,plev,nbulk) ) - - do iaer = 1, aero%nbulk - call rad_cnst_get_aer_props(0, iaer, & - aername = aername(iaer), & - num_to_mass_aer = aero%num_to_mass_aer(iaer) ) - - ! Look for sulfate aerosol in this list (Bulk aerosol only) - if (trim(aername(iaer)) == 'SULFATE') aero%idxsul = iaer - if (trim(aername(iaer)) == 'DUST1') aero%idxdst1 = iaer - if (trim(aername(iaer)) == 'DUST2') aero%idxdst2 = iaer - if (trim(aername(iaer)) == 'DUST3') aero%idxdst3 = iaer - if (trim(aername(iaer)) == 'DUST4') aero%idxdst4 = iaer - if (trim(aername(iaer)) == 'BCPHI') aero%idxbcphi = iaer - end do - - end if - - end subroutine zm_aero_init - - subroutine zm_conv_micro_outfld(conv, dnif, dnlf, lchnk, ncol) - - use cam_history, only: outfld - - type(zm_conv_t),intent(in) :: conv - real(r8), intent(in) :: dnlf(:,:) ! detrained convective cloud water num concen. - real(r8), intent(in) :: dnif(:,:) ! detrained convective cloud ice num concen. - integer, intent(in) :: lchnk - integer, intent(in) :: ncol - - integer :: i,k - - real(r8) :: cice_snum(pcols,pver) ! convective cloud ice sample number. - real(r8) :: cliq_snum(pcols,pver) ! convective cloud liquid sample number. - real(r8) :: crain_snum(pcols,pver) ! convective rain water sample number. - real(r8) :: csnow_snum(pcols,pver) ! convective snow sample number. - real(r8) :: wu_snum(pcols,pver) ! vertical velocity sample number - - real(r8) :: qni_snum(pcols,pver) ! convective cloud ice number sample number. - real(r8) :: qnl_snum(pcols,pver) ! convective cloud liquid number sample number. - - do k = 1,pver - do i = 1,ncol - if (conv%qice(i,k) .gt. 0.0_r8) then - cice_snum(i,k) = 1.0_r8 - else - cice_snum(i,k) = 0.0_r8 - end if - if (conv%qliq(i,k) .gt. 0.0_r8) then - cliq_snum(i,k) = 1.0_r8 - else - cliq_snum(i,k) = 0.0_r8 - end if - if (conv%qsnow(i,k) .gt. 0.0_r8) then - csnow_snum(i,k) = 1.0_r8 - else - csnow_snum(i,k) = 0.0_r8 - end if - if (conv%qrain(i,k) .gt. 0.0_r8) then - crain_snum(i,k) = 1.0_r8 - else - crain_snum(i,k) = 0.0_r8 - end if - - if (conv%qnl(i,k) .gt. 0.0_r8) then - qnl_snum(i,k) = 1.0_r8 - else - qnl_snum(i,k) = 0.0_r8 - end if - if (conv%qni(i,k) .gt. 0.0_r8) then - qni_snum(i,k) = 1.0_r8 - else - qni_snum(i,k) = 0.0_r8 - end if - if (conv%wu(i,k) .gt. 0.0_r8) then - wu_snum(i,k) = 1.0_r8 - else - wu_snum(i,k) = 0.0_r8 - end if - - end do - end do - - call outfld('ICIMRDP ',conv%qi ,pcols, lchnk ) - call outfld('CLDLIQZM',conv%qliq ,pcols, lchnk) - call outfld('CLDICEZM',conv%qice ,pcols, lchnk) - call outfld('CLIQSNUM',cliq_snum ,pcols, lchnk) - call outfld('CICESNUM',cice_snum ,pcols, lchnk) - call outfld('QRAINZM' ,conv%qrain ,pcols, lchnk) - call outfld('QSNOWZM' ,conv%qsnow ,pcols, lchnk) - call outfld('CRAINNUM',crain_snum ,pcols, lchnk) - call outfld('CSNOWNUM',csnow_snum ,pcols, lchnk) - - call outfld('WUZM' ,conv%wu ,pcols, lchnk) - call outfld('WUZMSNUM',wu_snum ,pcols, lchnk) - call outfld('QNLZM' ,conv%qnl ,pcols, lchnk) - call outfld('QNIZM' ,conv%qni ,pcols, lchnk) - call outfld('QNRZM' ,conv%qnr ,pcols, lchnk) - call outfld('QNSZM' ,conv%qns ,pcols, lchnk) - call outfld('FRZZM' ,conv%frz ,pcols, lchnk) - - call outfld('AUTOL_M' ,conv%autolm ,pcols, lchnk) - call outfld('ACCRL_M' ,conv%accrlm ,pcols, lchnk) - call outfld('BERGN_M' ,conv%bergnm ,pcols, lchnk) - call outfld('FHTIM_M' ,conv%fhtimm ,pcols, lchnk) - call outfld('FHTCT_M' ,conv%fhtctm ,pcols, lchnk) - call outfld('FHML_M' ,conv%fhmlm ,pcols, lchnk) - call outfld('HMPI_M' ,conv%hmpim ,pcols, lchnk) - call outfld('ACCSL_M' ,conv%accslm ,pcols, lchnk) - call outfld('DLF_M' ,conv%dlfm ,pcols, lchnk) - - call outfld('AUTOL_N' ,conv%autoln ,pcols, lchnk) - call outfld('ACCRL_N' ,conv%accrln ,pcols, lchnk) - call outfld('BERGN_N' ,conv%bergnn ,pcols, lchnk) - call outfld('FHTIM_N' ,conv%fhtimn ,pcols, lchnk) - call outfld('FHTCT_N' ,conv%fhtctn ,pcols, lchnk) - call outfld('FHML_N' ,conv%fhmln ,pcols, lchnk) - call outfld('ACCSL_N' ,conv%accsln ,pcols, lchnk) - call outfld('ACTIV_N' ,conv%activn ,pcols, lchnk) - call outfld('DLF_N' ,conv%dlfn ,pcols, lchnk) - call outfld('AUTOI_M' ,conv%autoim ,pcols, lchnk) - call outfld('ACCSI_M' ,conv%accsim ,pcols, lchnk) - call outfld('DIF_M' ,conv%difm ,pcols, lchnk) - call outfld('NUCLI_N' ,conv%nuclin ,pcols, lchnk) - call outfld('AUTOI_N' ,conv%autoin ,pcols, lchnk) - call outfld('ACCSI_N' ,conv%accsin ,pcols, lchnk) - call outfld('HMPI_N' ,conv%hmpin ,pcols, lchnk) - call outfld('DIF_N' ,conv%difn ,pcols, lchnk) - call outfld('COND_M' ,conv%cmel ,pcols, lchnk) - call outfld('DEPOS_M' ,conv%cmei ,pcols, lchnk) - - call outfld('TRSPC_M' ,conv%trspcm ,pcols, lchnk) - call outfld('TRSPC_N' ,conv%trspcn ,pcols, lchnk) - call outfld('TRSPI_M' ,conv%trspim ,pcols, lchnk) - call outfld('TRSPI_N' ,conv%trspin ,pcols, lchnk) - call outfld('DNIFZM' ,dnif ,pcols, lchnk) - call outfld('DNLFZM' ,dnlf ,pcols, lchnk) - - end subroutine zm_conv_micro_outfld end module zm_conv_intr diff --git a/src/physics/cam/zm_microphysics.F90 b/src/physics/cam/zm_microphysics.F90 deleted file mode 100644 index b54e1e684e..0000000000 --- a/src/physics/cam/zm_microphysics.F90 +++ /dev/null @@ -1,2455 +0,0 @@ -module zm_microphysics - -!--------------------------------------------------------------------------------- -! Purpose: -! CAM Interface for cumulus microphysics -! -! Author: Xialiang Song and Guang Jun Zhang, June 2010 -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8=>shr_kind_r8 -use spmd_utils, only: masterproc -use ppgrid, only: pcols, pver, pverp -use physconst, only: gravit, rair, tmelt, cpair, rh2o, r_universal, mwh2o, rhoh2o -use physconst, only: latvap, latice -!use activate_drop_mam, only: actdrop_mam_calc -use ndrop, only: activate_aerosol -use ndrop_bam, only: ndrop_bam_run -use nucleate_ice, only: nucleati -use shr_spfn_mod, only: erf => shr_spfn_erf -use shr_spfn_mod, only: gamma => shr_spfn_gamma -use wv_saturation, only: svp_water, svp_ice -use cam_logfile, only: iulog -use cam_abortutils, only: endrun -use micro_pumas_utils, only:ice_autoconversion, snow_self_aggregation, accrete_cloud_water_snow, & - secondary_ice_production, accrete_rain_snow, heterogeneous_rain_freezing, & - accrete_cloud_water_rain, self_collection_rain, accrete_cloud_ice_snow -use microp_aero, only: aerosol_properties_object -use aerosol_properties_mod, only: aerosol_properties - -implicit none -private -save - -public :: & - zm_mphyi, & - zm_mphy, & - zm_conv_t,& - zm_aero_t - -! Private module data - -! constants remaped -real(r8) :: g ! gravity -real(r8) :: mw ! molecular weight of water -real(r8) :: r ! Dry air Gas constant -real(r8) :: rv ! water vapor gas contstant -real(r8) :: rr ! universal gas constant -real(r8) :: cpp ! specific heat of dry air -real(r8) :: rhow ! density of liquid water -real(r8) :: xlf ! latent heat of freezing - -!from 'microconstants' -real(r8) :: rhosn ! bulk density snow -real(r8) :: rhoi ! bulk density ice - -real(r8) :: ac,bc,as,bs,ai,bi,ar,br !fall speed parameters -real(r8) :: ci,di !ice mass-diameter relation parameters -real(r8) :: cs,ds !snow mass-diameter relation parameters -real(r8) :: cr,dr !drop mass-diameter relation parameters -real(r8) :: Eii !collection efficiency aggregation of ice -real(r8) :: Ecc !collection efficiency -real(r8) :: Ecr !collection efficiency cloud droplets/rain -real(r8) :: DCS !autoconversion size threshold -real(r8) :: bimm,aimm !immersion freezing -real(r8) :: rhosu !typical 850mn air density -real(r8) :: mi0 ! new crystal mass -real(r8) :: rin ! radius of contact nuclei -real(r8) :: pi ! pi - -! contact freezing due to dust -! dust number mean radius (m), Zender et al JGR 2003 assuming number mode radius of 0.6 micron, sigma=2 -real(r8), parameter :: rn_dst1 = 0.258e-6_r8 -real(r8), parameter :: rn_dst2 = 0.717e-6_r8 -real(r8), parameter :: rn_dst3 = 1.576e-6_r8 -real(r8), parameter :: rn_dst4 = 3.026e-6_r8 - -! smallest mixing ratio considered in microphysics -real(r8), parameter :: qsmall = 1.e-18_r8 - - -type, public :: ptr2d - real(r8), pointer :: val(:,:) -end type ptr2d - -! Aerosols -type :: zm_aero_t - - ! Aerosol treatment - character(len=5) :: scheme ! either 'bulk' or 'modal' - - ! Bulk aerosols - integer :: nbulk = 0 ! number of bulk aerosols affecting climate - integer :: idxsul = -1 ! index in aerosol list for sulfate - integer :: idxdst1 = -1 ! index in aerosol list for dust1 - integer :: idxdst2 = -1 ! index in aerosol list for dust2 - integer :: idxdst3 = -1 ! index in aerosol list for dust3 - integer :: idxdst4 = -1 ! index in aerosol list for dust4 - integer :: idxbcphi = -1 ! index in aerosol list for Soot (BCPHI) - - real(r8), allocatable :: num_to_mass_aer(:) ! conversion of mmr to number conc for bulk aerosols - type(ptr2d), allocatable :: mmr_bulk(:) ! array of pointers to bulk aerosol mmr - real(r8), allocatable :: mmrg_bulk(:,:,:) ! gathered bulk aerosol mmr - - ! Modal aerosols - integer :: nmodes = 0 ! number of modes - integer, allocatable :: nspec(:) ! number of species in each mode - type(ptr2d), allocatable :: num_a(:) ! number mixing ratio of modes (interstitial phase) - type(ptr2d), allocatable :: mmr_a(:,:) ! species mmr in each mode (interstitial phase) - real(r8), allocatable :: numg_a(:,:,:) ! gathered number mixing ratio of modes (interstitial phase) - real(r8), allocatable :: mmrg_a(:,:,:,:) ! gathered species mmr in each mode (interstitial phase) - real(r8), allocatable :: voltonumblo(:) ! volume to number conversion (lower bound) for each mode - real(r8), allocatable :: voltonumbhi(:) ! volume to number conversion (upper bound) for each mode - real(r8), allocatable :: specdens(:,:) ! density of modal species - real(r8), allocatable :: spechygro(:,:) ! hygroscopicity of modal species - - integer :: mode_accum_idx = -1 ! index of accumulation mode - integer :: mode_aitken_idx = -1 ! index of aitken mode - integer :: mode_coarse_idx = -1 ! index of coarse mode - integer :: coarse_dust_idx = -1 ! index of dust in coarse mode - integer :: coarse_nacl_idx = -1 ! index of nacl in coarse mode - - type(ptr2d), allocatable :: dgnum(:) ! mode dry radius - real(r8), allocatable :: dgnumg(:,:,:) ! gathered mode dry radius - - real(r8) :: sigmag_aitken - -end type zm_aero_t - -type :: zm_conv_t - - real(r8), allocatable :: qi(:,:) ! wg grid slice of cloud ice. - real(r8), allocatable :: qliq(:,:) ! convective cloud liquid water. - real(r8), allocatable :: qice(:,:) ! convective cloud ice. - real(r8), allocatable :: wu(:,:) ! vertical velocity - real(r8), allocatable :: sprd(:,:) ! rate of production of snow at that layer - real(r8), allocatable :: qrain(:,:) ! convective rain water. - real(r8), allocatable :: qsnow(:,:) ! convective snow. - real(r8), allocatable :: qnl(:,:) ! convective cloud liquid water num concen. - real(r8), allocatable :: qni(:,:) ! convective cloud ice num concen. - real(r8), allocatable :: qnr(:,:) ! convective rain water num concen. - real(r8), allocatable :: qns(:,:) ! convective snow num concen. - real(r8), allocatable :: frz(:,:) ! heating rate due to freezing - real(r8), allocatable :: autolm(:,:) !mass tendency due to autoconversion of droplets to rain - real(r8), allocatable :: accrlm(:,:) !mass tendency due to accretion of droplets by rain - real(r8), allocatable :: bergnm(:,:) !mass tendency due to Bergeron process - real(r8), allocatable :: fhtimm(:,:) !mass tendency due to immersion freezing - real(r8), allocatable :: fhtctm(:,:) !mass tendency due to contact freezing - real(r8), allocatable :: fhmlm (:,:) !mass tendency due to homogeneous freezing - real(r8), allocatable :: hmpim (:,:) !mass tendency due to HM process - real(r8), allocatable :: accslm(:,:) !mass tendency due to accretion of droplets by snow - real(r8), allocatable :: dlfm (:,:) !mass tendency due to detrainment of droplet - real(r8), allocatable :: autoln(:,:) !num tendency due to autoconversion of droplets to rain - real(r8), allocatable :: accrln(:,:) !num tendency due to accretion of droplets by rain - real(r8), allocatable :: bergnn(:,:) !num tendency due to Bergeron process - real(r8), allocatable :: fhtimn(:,:) !num tendency due to immersion freezing - real(r8), allocatable :: fhtctn(:,:) !num tendency due to contact freezing - real(r8), allocatable :: fhmln (:,:) !num tendency due to homogeneous freezing - real(r8), allocatable :: accsln(:,:) !num tendency due to accretion of droplets by snow - real(r8), allocatable :: activn(:,:) !num tendency due to droplets activation - real(r8), allocatable :: dlfn (:,:) !num tendency due to detrainment of droplet - real(r8), allocatable :: autoim(:,:) !mass tendency due to autoconversion of cloud ice to snow - real(r8), allocatable :: accsim(:,:) !mass tendency due to accretion of cloud ice by snow - real(r8), allocatable :: difm (:,:) !mass tendency due to detrainment of cloud ice - real(r8), allocatable :: nuclin(:,:) !num tendency due to ice nucleation - real(r8), allocatable :: autoin(:,:) !num tendency due to autoconversion of cloud ice to snow - real(r8), allocatable :: accsin(:,:) !num tendency due to accretion of cloud ice by snow - real(r8), allocatable :: hmpin (:,:) !num tendency due to HM process - real(r8), allocatable :: difn (:,:) !num tendency due to detrainment of cloud ice - real(r8), allocatable :: cmel (:,:) !mass tendency due to condensation - real(r8), allocatable :: cmei (:,:) !mass tendency due to deposition - real(r8), allocatable :: trspcm(:,:) !LWC tendency due to convective transport - real(r8), allocatable :: trspcn(:,:) !droplet num tendency due to convective transport - real(r8), allocatable :: trspim(:,:) !IWC tendency due to convective transport - real(r8), allocatable :: trspin(:,:) !ice crystal num tendency due to convective transport - real(r8), allocatable :: dcape(:) ! CAPE change due to freezing heating - real(r8), allocatable :: lambdadpcu(:,:)! slope of cloud liquid size distr - real(r8), allocatable :: mudpcu(:,:) ! width parameter of droplet size distr - real(r8), allocatable :: di(:,:) - real(r8), allocatable :: dnl(:,:) - real(r8), allocatable :: dni(:,:) - real(r8), allocatable :: qide(:,:) ! cloud ice mixing ratio for detrainment (kg/kg) - real(r8), allocatable :: qncde(:,:) ! cloud water number concentration for detrainment (1/kg) - real(r8), allocatable :: qnide(:,:) ! cloud ice number concentration for detrainment (1/kg) - - -end type zm_conv_t - -real(r8), parameter :: dcon = 25.e-6_r8 -real(r8), parameter :: mucon = 5.3_r8 -real(r8), parameter :: lambdadpcu = (mucon + 1._r8)/dcon - -!=============================================================================== -contains -!=============================================================================== - -subroutine zm_mphyi - -!----------------------------------------------------------------------- -! -! Purpose: -! initialize constants for the cumulus microphysics -! called from zm_conv_init() in zm_conv_intr.F90 -! -! Author: Xialiang Song, June 2010 -! -!----------------------------------------------------------------------- - -!NOTE: -! latent heats should probably be fixed with temperature -! for energy conservation with the rest of the model -! (this looks like a +/- 3 or 4% effect, but will mess up energy balance) - - xlf = latice ! latent heat freezing - -! from microconstants - -! parameters below from Reisner et al. (1998) -! density parameters (kg/m3) - - rhosn = 100._r8 ! bulk density snow - rhoi = 500._r8 ! bulk density ice - rhow = 1000._r8 ! bulk density liquid - -! fall speed parameters, V = aD^b -! V is in m/s - -! droplets - ac = 3.e7_r8 - bc = 2._r8 - -! snow - as = 11.72_r8 - bs = 0.41_r8 - -! cloud ice - ai = 700._r8 - bi = 1._r8 - -! rain - ar = 841.99667_r8 - br = 0.8_r8 - -! particle mass-diameter relationship -! currently we assume spherical particles for cloud ice/snow -! m = cD^d - - pi= 3.14159265358979323846_r8 - -! cloud ice mass-diameter relationship - - ci = rhoi*pi/6._r8 - di = 3._r8 - -! snow mass-diameter relationship - - cs = rhosn*pi/6._r8 - ds = 3._r8 - -! drop mass-diameter relationship - - cr = rhow*pi/6._r8 - dr = 3._r8 - -! collection efficiency, aggregation of cloud ice and snow - - Eii = 0.1_r8 - -! collection efficiency, accretion of cloud water by rain - - Ecr = 1.0_r8 - -! autoconversion size threshold for cloud ice to snow (m) - - Dcs = 150.e-6_r8 -! immersion freezing parameters, bigg 1953 - - bimm = 100._r8 - aimm = 0.66_r8 - -! typical air density at 850 mb - - rhosu = 85000._r8/(rair * tmelt) - -! mass of new crystal due to aerosol freezing and growth (kg) - - mi0 = 4._r8/3._r8*pi*rhoi*(10.e-6_r8)*(10.e-6_r8)*(10.e-6_r8) - -! radius of contact nuclei aerosol (m) - - rin = 0.1e-6_r8 - -end subroutine zm_mphyi - -!=============================================================================== - -subroutine zm_mphy(su, qu, mu, du, eu, cmel, cmei, zf, pm, te, qe, & - eps0, jb, jt, jlcl, msg, il2g, grav, cp, rd, aero, gamhat, & - qc, qi, nc, ni, qcde, qide, ncde, nide, rprd, sprd, frz, & - wu, qr, qni, nr, ns, autolm, accrlm, bergnm, fhtimm, fhtctm, & - fhmlm, hmpim, accslm, dlfm, autoln, accrln, bergnn, fhtimn, fhtctn, & - fhmln, accsln, activn, dlfn, autoim, accsim, difm, nuclin, autoin, & - accsin, hmpin, difn, trspcm, trspcn, trspim, trspin, lamc, pgam ) - - -! Purpose: -! microphysic parameterization for Zhang-McFarlane convection scheme -! called from cldprp() in zm_conv.F90 -! -! Author: Xialiang Song, June 2010 - - use time_manager, only: get_step_size - -! variable declarations - - implicit none - -! input variables - real(r8), intent(in) :: su(pcols,pver) ! normalized dry stat energy of updraft - real(r8), intent(in) :: qu(pcols,pver) ! spec hum of updraft - real(r8), intent(in) :: mu(pcols,pver) ! updraft mass flux - real(r8), intent(in) :: du(pcols,pver) ! detrainement rate of updraft - real(r8), intent(in) :: eu(pcols,pver) ! entrainment rate of updraft - real(r8), intent(in) :: cmel(pcols,pver) ! condensation rate of updraft - real(r8), intent(in) :: cmei(pcols,pver) ! condensation rate of updraft - real(r8), intent(in) :: zf(pcols,pverp) ! height of interfaces - real(r8), intent(in) :: pm(pcols,pver) ! pressure of env - real(r8), intent(in) :: te(pcols,pver) ! temp of env - real(r8), intent(in) :: qe(pcols,pver) ! spec. humidity of env - real(r8), intent(in) :: eps0(pcols) - real(r8), intent(in) :: gamhat(pcols,pver) ! gamma=L/cp(dq*/dT) at interface - - integer, intent(in) :: jb(pcols) ! updraft base level - integer, intent(in) :: jt(pcols) ! updraft plume top - integer, intent(in) :: jlcl(pcols) ! updraft lifting cond level - integer, intent(in) :: msg ! missing moisture vals - integer, intent(in) :: il2g ! number of columns in gathered arrays - - type(zm_aero_t), intent(in) :: aero ! aerosol object - - real(r8) grav ! gravity - real(r8) cp ! heat capacity of dry air - real(r8) rd ! gas constant for dry air - -! output variables - real(r8), intent(out) :: qc(pcols,pver) ! cloud water mixing ratio (kg/kg) - real(r8), intent(out) :: qi(pcols,pver) ! cloud ice mixing ratio (kg/kg) - real(r8), intent(out) :: nc(pcols,pver) ! cloud water number conc (1/kg) - real(r8), intent(out) :: ni(pcols,pver) ! cloud ice number conc (1/kg) - real(r8), intent(out) :: qcde(pcols,pver) ! cloud water mixing ratio for detrainment(kg/kg) - real(r8), intent(out) :: qide(pcols,pver) ! cloud ice mixing ratio for detrainment (kg/kg) - real(r8), intent(out) :: ncde(pcols,pver) ! cloud water number conc for detrainment (1/kg) - real(r8), intent(out) :: nide(pcols,pver) ! cloud ice number conc for detrainment (1/kg) - real(r8), intent(out) :: wu(pcols,pver) - real(r8), intent(out) :: qni(pcols,pver) ! snow mixing ratio - real(r8), intent(out) :: qr(pcols,pver) ! rain mixing ratio - real(r8), intent(out) :: ns(pcols,pver) ! snow number conc - real(r8), intent(out) :: nr(pcols,pver) ! rain number conc - real(r8), intent(out) :: rprd(pcols,pver) ! rate of production of precip at that layer - real(r8), intent(out) :: sprd(pcols,pver) ! rate of production of snow at that layer - real(r8), intent(out) :: frz(pcols,pver) ! rate of freezing - - - real(r8), intent(inout) :: lamc(pcols,pver) ! slope of cloud liquid size distr - real(r8), intent(inout) :: pgam(pcols,pver) ! spectral width parameter of droplet size distr - -! tendency for output - real(r8),intent(out) :: autolm(pcols,pver) !mass tendency due to autoconversion of droplets to rain - real(r8),intent(out) :: accrlm(pcols,pver) !mass tendency due to accretion of droplets by rain - real(r8),intent(out) :: bergnm(pcols,pver) !mass tendency due to Bergeron process - real(r8),intent(out) :: fhtimm(pcols,pver) !mass tendency due to immersion freezing - real(r8),intent(out) :: fhtctm(pcols,pver) !mass tendency due to contact freezing - real(r8),intent(out) :: fhmlm (pcols,pver) !mass tendency due to homogeneous freezing - real(r8),intent(out) :: hmpim (pcols,pver) !mass tendency due to HM process - real(r8),intent(out) :: accslm(pcols,pver) !mass tendency due to accretion of droplets by snow - real(r8),intent(out) :: dlfm (pcols,pver) !mass tendency due to detrainment of droplet - real(r8),intent(out) :: trspcm(pcols,pver) !mass tendency of droplets due to convective transport - - real(r8),intent(out) :: autoln(pcols,pver) !num tendency due to autoconversion of droplets to rain - real(r8),intent(out) :: accrln(pcols,pver) !num tendency due to accretion of droplets by rain - real(r8),intent(out) :: bergnn(pcols,pver) !num tendency due to Bergeron process - real(r8),intent(out) :: fhtimn(pcols,pver) !num tendency due to immersion freezing - real(r8),intent(out) :: fhtctn(pcols,pver) !num tendency due to contact freezing - real(r8),intent(out) :: fhmln (pcols,pver) !num tendency due to homogeneous freezing - real(r8),intent(out) :: accsln(pcols,pver) !num tendency due to accretion of droplets by snow - real(r8),intent(out) :: activn(pcols,pver) !num tendency due to droplets activation - real(r8),intent(out) :: dlfn (pcols,pver) !num tendency due to detrainment of droplet - real(r8),intent(out) :: trspcn(pcols,pver) !num tendency of droplets due to convective transport - - real(r8),intent(out) :: autoim(pcols,pver) !mass tendency due to autoconversion of cloud ice to snow - real(r8),intent(out) :: accsim(pcols,pver) !mass tendency due to accretion of cloud ice by snow - real(r8),intent(out) :: difm (pcols,pver) !mass tendency due to detrainment of cloud ice - real(r8),intent(out) :: trspim(pcols,pver) !mass tendency of ice crystal due to convective transport - - real(r8),intent(out) :: nuclin(pcols,pver) !num tendency due to ice nucleation - real(r8),intent(out) :: autoin(pcols,pver) !num tendency due to autoconversion of cloud ice to snow - real(r8),intent(out) :: accsin(pcols,pver) !num tendency due to accretion of cloud ice by snow - real(r8),intent(out) :: hmpin (pcols,pver) !num tendency due to HM process - real(r8),intent(out) :: difn (pcols,pver) !num tendency due to detrainment of cloud ice - real(r8),intent(out) :: trspin(pcols,pver) !num tendency of ice crystal due to convective transport - -!................................................................................ -! local workspace -! all units mks unless otherwise stated - real(r8) :: deltat ! time step (s) - real(r8) :: omsm ! number near unity for round-off issues - real(r8) :: dum ! temporary dummy variable - real(r8) :: dum1 ! temporary dummy variable - real(r8) :: dum2 ! temporary dummy variable - - real(r8) :: q(pcols,pver) ! water vapor mixing ratio (kg/kg) - real(r8) :: t(pcols,pver) ! temperature (K) - real(r8) :: rho(pcols,pver) ! air density (kg m-3) - real(r8) :: dz(pcols,pver) ! height difference across model vertical level - - real(r8) :: qcic(pcols,pver) ! in-cloud cloud liquid mixing ratio - real(r8) :: qiic(pcols,pver) ! in-cloud cloud ice mixing ratio - real(r8) :: qniic(pcols,pver) ! in-precip snow mixing ratio - real(r8) :: qric(pcols,pver) ! in-precip rain mixing ratio - real(r8) :: ncic(pcols,pver) ! in-cloud droplet number conc - real(r8) :: niic(pcols,pver) ! in-cloud cloud ice number conc - real(r8) :: nsic(pcols,pver) ! in-precip snow number conc - real(r8) :: nric(pcols,pver) ! in-precip rain number conc - - real(r8) :: lami(pver) ! slope of cloud ice size distr - real(r8) :: n0i(pver) ! intercept of cloud ice size distr - real(r8) :: n0c(pver) ! intercept of cloud liquid size distr - real(r8) :: lams(pver) ! slope of snow size distr - real(r8) :: n0s(pver) ! intercept of snow size distr - real(r8) :: lamr(pver) ! slope of rain size distr - real(r8) :: n0r(pver) ! intercept of rain size distr - real(r8) :: cdist1(pver) ! size distr parameter to calculate droplet freezing - real(r8) :: lammax ! maximum allowed slope of size distr - real(r8) :: lammin ! minimum allowed slope of size distr - - real(r8) :: mnuccc(pver) ! mixing ratio tendency due to freezing of cloud water - real(r8) :: nnuccc(pver) ! number conc tendency due to freezing of cloud water - real(r8) :: mnucct(pver) ! mixing ratio tendency due to contact freezing of cloud water - real(r8) :: nnucct(pver) ! number conc tendency due to contact freezing of cloud water - real(r8) :: msacwi(pver) ! mixing ratio tendency due to HM ice multiplication - real(r8) :: nsacwi(pver) ! number conc tendency due to HM ice multiplication - real(r8) :: prf(pver) ! mixing ratio tendency due to fallout of rain - real(r8) :: psf(pver) ! mixing ratio tendency due to fallout of snow - real(r8) :: pnrf(pver) ! number conc tendency due to fallout of rain - real(r8) :: pnsf(pver) ! number conc tendency due to fallout of snow - real(r8) :: prc(pver) ! mixing ratio tendency due to autoconversion of cloud droplets - real(r8) :: nprc(pver) ! number conc tendency due to autoconversion of cloud droplets - real(r8) :: nprc1(pver) ! qr tendency due to autoconversion of cloud droplets - real(r8) :: nsagg(pver) ! ns tendency due to self-aggregation of snow - real(r8) :: dc0 ! mean size droplet size distr - real(r8) :: ds0 ! mean size snow size distr (area weighted) - real(r8) :: eci ! collection efficiency for riming of snow by droplets - real(r8) :: dv(pcols,pver) ! diffusivity of water vapor in air - real(r8) :: mua(pcols,pver) ! viscocity of air - real(r8) :: psacws(pver) ! mixing rat tendency due to collection of droplets by snow - real(r8) :: npsacws(pver) ! number conc tendency due to collection of droplets by snow - real(r8) :: pracs(pver) ! mixing rat tendency due to collection of rain by snow - real(r8) :: npracs(pver) ! number conc tendency due to collection of rain by snow - real(r8) :: mnuccr(pver) ! mixing rat tendency due to freezing of rain - real(r8) :: nnuccr(pver) ! number conc tendency due to freezing of rain - real(r8) :: pra(pver) ! mixing rat tendnency due to accretion of droplets by rain - real(r8) :: npra(pver) ! nc tendnency due to accretion of droplets by rain - real(r8) :: nragg(pver) ! nr tendency due to self-collection of rain - real(r8) :: prci(pver) ! mixing rat tendency due to autoconversion of cloud ice to snow - real(r8) :: nprci(pver) ! number conc tendency due to autoconversion of cloud ice to snow - real(r8) :: prai(pver) ! mixing rat tendency due to accretion of cloud ice by snow - real(r8) :: nprai(pver) ! number conc tendency due to accretion of cloud ice by snow - real(r8) :: prb(pver) ! rain mixing rat tendency due to Bergeron process - real(r8) :: nprb(pver) ! number conc tendency due to Bergeron process - real(r8) :: fhmrm (pcols,pver) !mass tendency due to homogeneous freezing of rain - -! fall speed - real(r8) :: arn(pcols,pver) ! air density corrected rain fallspeed parameter - real(r8) :: asn(pcols,pver) ! air density corrected snow fallspeed parameter - real(r8) :: acn(pcols,pver) ! air density corrected cloud droplet fallspeed parameter - real(r8) :: ain(pcols,pver) ! air density corrected cloud ice fallspeed parameter - real(r8) :: uns(pver) ! number-weighted snow fallspeed - real(r8) :: ums(pver) ! mass-weighted snow fallspeed - real(r8) :: unr(pver) ! number-weighted rain fallspeed - real(r8) :: umr(pver) ! mass-weighted rain fallspeed - -! conservation check - real(r8) :: qce ! dummy qc for conservation check - real(r8) :: qie ! dummy qi for conservation check - real(r8) :: nce ! dummy nc for conservation check - real(r8) :: nie ! dummy ni for conservation check - real(r8) :: qre ! dummy qr for conservation check - real(r8) :: nre ! dummy nr for conservation check - real(r8) :: qnie ! dummy qni for conservation check - real(r8) :: nse ! dummy ns for conservation check - real(r8) :: ratio ! parameter for conservation check - -! sum of source/sink terms for cloud hydrometeor - real(r8) :: qctend(pcols,pver) ! microphysical tendency qc (1/s) - real(r8) :: qitend(pcols,pver) ! microphysical tendency qi (1/s) - real(r8) :: nctend(pcols,pver) ! microphysical tendency nc (1/(kg*s)) - real(r8) :: nitend(pcols,pver) ! microphysical tendency ni (1/(kg*s)) - real(r8) :: qnitend(pcols,pver) ! snow mixing ratio source/sink term - real(r8) :: nstend(pcols,pver) ! snow number concentration source/sink term - real(r8) :: qrtend(pcols,pver) ! rain mixing ratio source/sink term - real(r8) :: nrtend(pcols,pver) ! rain number concentration source/sink term - -! terms for Bergeron process - real(r8) :: bergtsf !bergeron timescale to remove all liquid - real(r8) :: plevap ! cloud liquid water evaporation rate - -! variables for droplet activation by modal aerosols - real(r8) :: wmix, wmin, wmax, wdiab - real(r8) :: vol, nlsrc - real(r8), allocatable :: vaerosol(:), hygro(:), naermod(:) - real(r8), allocatable :: fn(:) ! number fraction of aerosols activated - real(r8), allocatable :: fm(:) ! mass fraction of aerosols activated - real(r8), allocatable :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) - real(r8), allocatable :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) - real(r8) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) - real(r8) :: dmc - real(r8) :: ssmc - real(r8) :: dgnum_aitken - -! bulk aerosol variables - real(r8), allocatable :: naer2(:,:,:) ! new aerosol number concentration (/m3) - real(r8), allocatable :: naer2h(:,:,:) ! new aerosol number concentration (/m3) - real(r8), allocatable :: maerosol(:) ! aerosol mass conc (kg/m3) - real(r8) :: so4_num - real(r8) :: soot_num - real(r8) :: dst1_num - real(r8) :: dst2_num - real(r8) :: dst3_num - real(r8) :: dst4_num - real(r8) :: dst_num - -! droplet activation - logical :: in_cloud ! true when above cloud base layer (k > jb) - real(r8) :: smax_f ! droplet and rain size distr factor used in the - ! in-cloud smax calculation - real(r8) :: dum2l(pcols,pver) ! number conc of CCN (1/kg) - real(r8) :: npccn(pver) ! droplet activation rate - real(r8) :: ncmax - real(r8) :: mtimec ! factor to account for droplet activation timescale - -! ice nucleation - real(r8) :: dum2i(pcols,pver) ! number conc of ice nuclei available (1/kg) - real(r8) :: qs(pcols,pver) ! liquid-ice weighted sat mixing rat (kg/kg) - real(r8) :: es(pcols,pver) ! sat vapor press (pa) over water - real(r8) :: relhum(pcols,pver) ! relative humidity - real(r8) :: esi(pcols,pver) ! sat vapor press (pa) over ice - real(r8) :: nnuccd(pver) ! ice nucleation rate from deposition/cond.-freezing - real(r8) :: mnuccd(pver) ! mass tendency from ice nucleation - real(r8) :: mtime ! factor to account for ice nucleation timescale - -! output for ice nucleation - real(r8) :: nimey(pcols,pver) !number conc of ice nuclei due to meyers deposition (1/m3) - real(r8) :: nihf(pcols,pver) !number conc of ice nuclei due to heterogenous freezing (1/m3) - real(r8) :: nidep(pcols,pver) !number conc of ice nuclei due to deoposion nucleation (hetero nuc) (1/m3) - real(r8) :: niimm(pcols,pver) !number conc of ice nuclei due to immersion freezing (hetero nuc) (1/m3) - - real(r8) :: wpice, weff, fhom ! unused dummies - -! loop array variables - integer i,k, n, l - integer ii,kk, m - -! loop variables for iteration solution - integer iter,it,ltrue(pcols) - -! used in contact freezing via dust particles - real(r8) tcnt, viscosity, mfp - real(r8) slip1, slip2, slip3, slip4 - real(r8) dfaer1, dfaer2, dfaer3, dfaer4 - real(r8) nacon1,nacon2,nacon3,nacon4 - -! used in immersion freezing via soot - real(r8) ttend(pver) - real(r8) naimm - real(r8) :: ntaer(pcols,pver) - real(r8) :: ntaerh(pcols,pver) - -! used in homogeneous freezing - real(r8) :: fholm (pcols,pver) !mass tendency due to homogeneous freezing - real(r8) :: fholn (pcols,pver) !number conc tendency due to homogeneous freezing - -! used in secondary ice production - real(r8) ni_secp - -! used in vertical velocity calculation - real(r8) th(pcols,pver) - real(r8) qh(pcols,pver) - real(r8) zkine(pcols,pver) - real(r8) zbuo(pcols,pver) - real(r8) zfacbuo, cwdrag, cwifrac, retv, zbuoc - real(r8) zbc, zbe, zdkbuo, zdken - real(r8) arcf(pcols,pver) - real(r8) p(pcols,pver) - real(r8) ph(pcols,pver) - -! used in vertical integreation - logical qcimp(pver) ! true to solve qc with implicit formula - logical ncimp(pver) ! true to solve nc with implicit formula - logical qiimp(pver) ! true to solve qi with implicit formula - logical niimp(pver) ! true to solve ni with implicit formula - -! tendency due to adjustment - real(r8) :: ncadj(pcols,pver) !droplet num tendency due to adjustment - real(r8) :: niadj(pcols,pver) !ice crystal num tendency due to adjustment - real(r8) :: ncorg, niorg, total - - real(r8) :: rhoh(pcols,pver) ! air density (kg m-3) at interface - real(r8) :: rhom(pcols,pver) ! air density (kg m-3) at mid-level - real(r8) :: tu(pcols,pver) ! temperature in updraft (K) - - integer kqi(pcols),kqc(pcols) - logical lcbase(pcols), libase(pcols) - - real(r8) :: nai_bcphi, nai_dst1, nai_dst2, nai_dst3, nai_dst4 - - real(r8) flxrm, mvtrm, flxrn, mvtrn, flxsm, mvtsm, flxsn, mvtsn - integer nlr, nls - - real(r8) rmean, beta6, beta66, r6, r6c - real(r8) temp1, temp2, temp3, temp4 ! variable to store output which is not required by this routine - - class(aerosol_properties), pointer :: aero_props_obj => null() - -! Aerosol properties - aero_props_obj => aerosol_properties_object() - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! initialization -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - if (aero%scheme == 'modal') then - - allocate(vaerosol(aero%nmodes), hygro(aero%nmodes), naermod(aero%nmodes), & - fn(aero%nmodes), fm(aero%nmodes), fluxn(aero%nmodes), fluxm(aero%nmodes)) - - else if (aero%scheme == 'bulk') then - - allocate( & - naer2(pcols,pver,aero%nbulk), & - naer2h(pcols,pver,aero%nbulk), & - maerosol(aero%nbulk)) - - end if - - deltat= get_step_size() !for FV dynamical core - - ! parameters for scheme - omsm=0.99999_r8 - zfacbuo = 0.5_r8/(1._r8+0.5_r8) - cwdrag = 1.875_r8*0.506_r8 - cwifrac = 0.5_r8 - retv = 0.608_r8 - bergtsf = 1800._r8 - - ! initialize multi-level fields - do i=1,il2g - do k=1,pver - q(i,k) = qu(i,k) - tu(i,k)= su(i,k) - grav/cp*zf(i,k) - t(i,k) = su(i,k) - grav/cp*zf(i,k) - p(i,k) = 100._r8*pm(i,k) - wu(i,k) = 0._r8 - zkine(i,k)= 0._r8 - arcf(i,k) = 0._r8 - zbuo(i,k) = 0._r8 - nc(i,k) = 0._r8 - ni(i,k) = 0._r8 - qc(i,k) = 0._r8 - qi(i,k) = 0._r8 - ncde(i,k) = 0._r8 - nide(i,k) = 0._r8 - qcde(i,k) = 0._r8 - qide(i,k) = 0._r8 - rprd(i,k) = 0._r8 - sprd(i,k) = 0._r8 - frz(i,k) = 0._r8 - qcic(i,k) = 0._r8 - qiic(i,k) = 0._r8 - ncic(i,k) = 0._r8 - niic(i,k) = 0._r8 - qr(i,k) = 0._r8 - qni(i,k) = 0._r8 - nr(i,k) = 0._r8 - ns(i,k) = 0._r8 - qric(i,k) = 0._r8 - qniic(i,k) = 0._r8 - nric(i,k) = 0._r8 - nsic(i,k) = 0._r8 - nimey(i,k) = 0._r8 - nihf(i,k) = 0._r8 - nidep(i,k) = 0._r8 - niimm(i,k) = 0._r8 - fhmrm(i,k) = 0._r8 - - autolm(i,k) = 0._r8 - accrlm(i,k) = 0._r8 - bergnm(i,k) = 0._r8 - fhtimm(i,k) = 0._r8 - fhtctm(i,k) = 0._r8 - fhmlm (i,k) = 0._r8 - fholm (i,k) = 0._r8 - hmpim (i,k) = 0._r8 - accslm(i,k) = 0._r8 - dlfm (i,k) = 0._r8 - - autoln(i,k) = 0._r8 - accrln(i,k) = 0._r8 - bergnn(i,k) = 0._r8 - fhtimn(i,k) = 0._r8 - fhtctn(i,k) = 0._r8 - fhmln (i,k) = 0._r8 - fholn (i,k) = 0._r8 - accsln(i,k) = 0._r8 - activn(i,k) = 0._r8 - dlfn (i,k) = 0._r8 - - autoim(i,k) = 0._r8 - accsim(i,k) = 0._r8 - difm (i,k) = 0._r8 - - nuclin(i,k) = 0._r8 - autoin(i,k) = 0._r8 - accsin(i,k) = 0._r8 - hmpin (i,k) = 0._r8 - difn (i,k) = 0._r8 - - trspcm(i,k) = 0._r8 - trspcn(i,k) = 0._r8 - trspim(i,k) = 0._r8 - trspin(i,k) = 0._r8 - - ncadj (i,k) = 0._r8 - niadj (i,k) = 0._r8 - end do - end do - - ! initialize time-varying parameters - do k=1,pver - do i=1,il2g - if (k .eq.1) then - rhoh(i,k) = p(i,k)/(t(i,k)*rd) - rhom(i,k) = p(i,k)/(t(i,k)*rd) - th (i,k) = te(i,k) - qh (i,k) = qe(i,k) - dz (i,k) = zf(i,k) - zf(i,k+1) - ph(i,k) = p(i,k) - else - rhoh(i,k) = 0.5_r8*(p(i,k)+p(i,k-1))/(t(i,k)*rd) - if (k .eq. pver) then - rhom(i,k) = p(i,k)/(rd*t(i,k)) - else - rhom(i,k) = 2.0_r8*p(i,k)/(rd*(t(i,k)+t(i,k+1))) - end if - th (i,k) = 0.5_r8*(te(i,k)+te(i,k-1)) - qh (i,k) = 0.5_r8*(qe(i,k)+qe(i,k-1)) - dz(i,k) = zf(i,k-1) - zf(i,k) - ph(i,k) = 0.5_r8*(p(i,k) + p(i,k-1)) - end if - dv(i,k) = 8.794E-5_r8*t(i,k)**1.81_r8/ph(i,k) - mua(i,k) = 1.496E-6_r8*t(i,k)**1.5_r8/ & - (t(i,k)+120._r8) - - rho(i,k) = rhoh(i,k) - - ! air density adjustment for fallspeed parameters - ! add air density correction factor to the power of - ! 0.54 following Heymsfield and Bansemer 2006 - - arn(i,k)=ar*(rhosu/rho(i,k))**0.54_r8 - asn(i,k)=as*(rhosu/rho(i,k))**0.54_r8 - acn(i,k)=ac*(rhosu/rho(i,k))**0.54_r8 - ain(i,k)=ai*(rhosu/rho(i,k))**0.54_r8 - - end do - end do - - if (aero%scheme == 'modal') then - - wmix = 0._r8 - wmin = 0._r8 - wmax = 10._r8 - wdiab = 0._r8 - - do k=1,pver - do i=1,il2g - dum2l(i,k)=0._r8 - dum2i(i,k)=0._r8 - ntaer(i,k) = 0.0_r8 - ntaerh(i,k) = 0.0_r8 - do m = 1, aero%nmodes - ntaer(i,k) = ntaer(i,k) + aero%numg_a(i,k,m)*rhom(i,k) - enddo - end do - end do - - else if (aero%scheme == 'bulk') then - - ! initialize aerosol number - do k=1,pver - do i=1,il2g - naer2(i,k,:)=0._r8 - naer2h(i,k,:)=0._r8 - dum2l(i,k)=0._r8 - dum2i(i,k)=0._r8 - end do - end do - - do k=1,pver - do i=1,il2g - ntaer(i,k) = 0.0_r8 - ntaerh(i,k) = 0.0_r8 - do m = 1, aero%nbulk - maerosol(m) = aero%mmrg_bulk(i,k,m)*rhom(i,k) - - ! set number nucleated for sulfate based on Lohmann et al. 2000 (JGR) Eq.2 - ! Na=340.*(massSO4)^0.58 where Na=cm-3 and massSO4=ug/m3 - ! convert units to Na [m-3] and SO4 [kgm-3] - ! Na(m-3)= 1.e6 cm3 m-3 Na(cm-3)=340. *(massSO4[kg/m3]*1.e9ug/kg)^0.58 - ! or Na(m-3)= 1.e6* 340.*(1.e9ug/kg)^0.58 * (massSO4[kg/m3])^0.58 - - if (m .eq. aero%idxsul) then - naer2(i,k,m)= 5.64259e13_r8 * maerosol(m)**0.58_r8 - else - naer2(i,k,m)=maerosol(m)*aero%num_to_mass_aer(m) - end if - ntaer(i,k) = ntaer(i,k) + naer2(i,k,m) - end do - end do - end do - - end if - - do i=1,il2g - ltrue(i)=0 - do k=1,pver - if (qc(i,k).ge.qsmall.or.qi(i,k).ge.qsmall.or.cmel(i,k).ge.qsmall.or.cmei(i,k).ge.qsmall) ltrue(i)=1 - end do - end do - - ! skip microphysical calculations if no cloud water - do i=1,il2g - if (ltrue(i).eq.0) then - do k=1,pver - qctend(i,k)=0._r8 - qitend(i,k)=0._r8 - qnitend(i,k)=0._r8 - qrtend(i,k)=0._r8 - nctend(i,k)=0._r8 - nitend(i,k)=0._r8 - nrtend(i,k)=0._r8 - nstend(i,k)=0._r8 - qniic(i,k)=0._r8 - qric(i,k)=0._r8 - nsic(i,k)=0._r8 - nric(i,k)=0._r8 - qni(i,k)=0._r8 - qr(i,k)=0._r8 - ns(i,k)=0._r8 - nr(i,k)=0._r8 - qc(i,k) = 0._r8 - qi(i,k) = 0._r8 - nc(i,k) = 0._r8 - ni(i,k) = 0._r8 - qcde(i,k) = 0._r8 - qide(i,k) = 0._r8 - ncde(i,k) = 0._r8 - nide(i,k) = 0._r8 - rprd(i,k) = 0._r8 - sprd(i,k) = 0._r8 - frz(i,k) = 0._r8 - end do - goto 300 - end if - - kqc(i) = 1 - kqi(i) = 1 - lcbase(i) = .true. - libase(i) = .true. - - ! assign number of steps for iteration - ! use 2 steps following Song and Zhang, 2011, J. Clim. - iter = 2 - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! iteration - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - do it=1,iter - - ! initialize sub-step microphysical tendencies - do k=1,pver - qctend(i,k)=0._r8 - qitend(i,k)=0._r8 - qnitend(i,k)=0._r8 - qrtend(i,k)=0._r8 - nctend(i,k)=0._r8 - nitend(i,k)=0._r8 - nrtend(i,k)=0._r8 - nstend(i,k)=0._r8 - rprd(i,k) = 0._r8 - sprd(i,k) = 0._r8 - frz(i,k) = 0._r8 - qniic(i,k)=0._r8 - qric(i,k)=0._r8 - nsic(i,k)=0._r8 - nric(i,k)=0._r8 - qiic(i,k)=0._r8 - qcic(i,k)=0._r8 - niic(i,k)=0._r8 - ncic(i,k)=0._r8 - qcimp(k) = .false. - ncimp(k) = .false. - qiimp(k) = .false. - niimp(k) = .false. - dum2l(i,k)=0._r8 - dum2i(i,k)=0._r8 - autolm(i,k) = 0._r8 - accrlm(i,k) = 0._r8 - bergnm(i,k) = 0._r8 - fhtimm(i,k) = 0._r8 - fhtctm(i,k) = 0._r8 - fhmlm (i,k) = 0._r8 - fholm (i,k) = 0._r8 - hmpim (i,k) = 0._r8 - accslm(i,k) = 0._r8 - dlfm (i,k) = 0._r8 - - autoln(i,k) = 0._r8 - accrln(i,k) = 0._r8 - bergnn(i,k) = 0._r8 - fhtimn(i,k) = 0._r8 - fhtctn(i,k) = 0._r8 - fhmln (i,k) = 0._r8 - fholn (i,k) = 0._r8 - accsln(i,k) = 0._r8 - activn(i,k) = 0._r8 - dlfn (i,k) = 0._r8 - ncadj (i,k) = 0._r8 - - autoim(i,k) = 0._r8 - accsim(i,k) = 0._r8 - difm (i,k) = 0._r8 - - nuclin(i,k) = 0._r8 - autoin(i,k) = 0._r8 - accsin(i,k) = 0._r8 - hmpin (i,k) = 0._r8 - difn (i,k) = 0._r8 - niadj (i,k) = 0._r8 - - trspcm(i,k) = 0._r8 - trspcn(i,k) = 0._r8 - trspim(i,k) = 0._r8 - trspin(i,k) = 0._r8 - - fhmrm (i,k) = 0._r8 - end do - - do k = pver,msg+2,-1 - - es(i,k) = svp_water(t(i,k)) ! over water in mixed clouds - esi(i,k) = svp_ice(t(i,k)) ! over ice - - if (k > jt(i) .and. k <= jb(i) .and. eps0(i) > 0._r8 & - .and.mu(i,k).gt.0._r8 .and. mu(i,k-1).gt.0._r8) then - - ! initialize precip fallspeeds to zero - if (it.eq.1) then - ums(k)=0._r8 - uns(k)=0._r8 - umr(k)=0._r8 - unr(k)=0._r8 - prf(k)=0._r8 - pnrf(k)=0._r8 - psf(k) =0._r8 - pnsf(k) = 0._r8 - end if - ttend(k)=0._r8 - nnuccd(k)=0._r8 - npccn(k)=0._r8 - - !************************************************************************************ - ! obtain values of cloud water/ice mixing ratios and number concentrations in updraft - ! for microphysical process calculations - ! units are kg/kg for mixing ratio, 1/kg for number conc - !************************************************************************************ - - - if (it.eq.1) then - qcic(i,k) = qc(i,k) - qiic(i,k) = qi(i,k) - ncic(i,k) = nc(i,k) - niic(i,k) = ni(i,k) - qniic(i,k)= qni(i,k) - qric(i,k) = qr(i,k) - nsic(i,k) = ns(i,k) - nric(i,k) = nr(i,k) - else - if (k.le.kqc(i)) then - qcic(i,k) = qc(i,k) - ncic(i,k) = nc(i,k) - - ! consider rain falling from above - flxrm = 0._r8 - mvtrm = 0._r8 - flxrn = 0._r8 - mvtrn = 0._r8 - nlr = 0 - - do kk= k,jt(i)+3,-1 - if (qr(i,kk-1) .gt. 0._r8) then - nlr = nlr + 1 - flxrm = flxrm + umr(kk-1)*qr(i,kk-1)*arcf(i,kk-1) - flxrn = flxrn + unr(kk-1)*nr(i,kk-1)*arcf(i,kk-1) - mvtrm = mvtrm + umr(kk-1)*arcf(i,kk-1) - mvtrn = mvtrn + unr(kk-1)*arcf(i,kk-1) - end if - end do - if (mvtrm.gt.0) then - qric(i,k) = (qr(i,k)*mu(i,k)+flxrm)/(mu(i,k)+mvtrm) - else - qric(i,k) = qr(i,k) - end if - if (mvtrn.gt.0) then - nric(i,k) = (nr(i,k)*mu(i,k)+flxrn)/(mu(i,k)+mvtrn) - else - nric(i,k) = nr(i,k) - end if - - end if - if (k.eq.kqc(i)) then - qcic(i,k) = qc(i,k-1) - ncic(i,k) = nc(i,k-1) - end if - if(k.le.kqi(i)) then - qiic(i,k) = qi(i,k) - niic(i,k) = ni(i,k) -! consider snow falling from above - flxsm = 0._r8 - mvtsm = 0._r8 - flxsn = 0._r8 - mvtsn = 0._r8 - nls = 0 - - do kk= k,jt(i)+3,-1 - if (qni(i,kk-1) .gt. 0._r8) then - nls = nls + 1 - flxsm = flxsm + ums(kk-1)*qni(i,kk-1)*arcf(i,kk-1) - mvtsm = mvtsm + ums(kk-1)*arcf(i,kk-1) - flxsn = flxsn + uns(kk-1)*ns(i,kk-1)*arcf(i,kk-1) - mvtsn = mvtsn + uns(kk-1)*arcf(i,kk-1) - end if - end do - - if (mvtsm.gt.0) then - qniic(i,k) = (qni(i,k)*mu(i,k)+flxsm)/(mu(i,k)+mvtsm) - else - qniic(i,k) = qni(i,k) - end if - if (mvtsn.gt.0) then - nsic(i,k) = (ns(i,k)*mu(i,k)+flxsn)/(mu(i,k)+mvtsn) - else - nsic(i,k) = ns(i,k) - end if - end if - if(k.eq.kqi(i)) then - qiic(i,k) = qi(i,k-1) - niic(i,k) = ni(i,k-1) - end if - end if - - !********************************************************************** - ! boundary condition for cloud liquid water and cloud ice - !*********************************************************************** - - ! boundary condition for provisional cloud water - if (cmel(i,k-1).gt.qsmall .and. lcbase(i) .and. it.eq.1 ) then - kqc(i) = k - lcbase(i) = .false. - qcic(i,k) = dz(i,k)*cmel(i,k-1)/(mu(i,k-1)+dz(i,k)*du(i,k-1)) - ncic(i,k) = qcic(i,k)/(4._r8/3._r8*pi*10.e-6_r8**3*rhow) - end if - - ! boundary condition for provisional cloud ice - if (qiic(i,k).gt.qsmall .and. libase(i) .and. it.eq.1 ) then - kqi(i) = k - libase(i) = .false. - else if ( cmei(i,k-1).gt.qsmall .and. & - cmei(i,k).lt.qsmall .and. k.le.jb(i) .and. libase(i) .and. it.eq.1 ) then - kqi(i)=k - libase(i) = .false. - qiic(i,k) = dz(i,k)*cmei(i,k-1)/(mu(i,k-1)+dz(i,k)*du(i,k-1)) - niic(i,k) = qiic(i,k)/(4._r8/3._r8*pi*25.e-6_r8**3*rhoi) - end if - - !*************************************************************************** - ! get size distribution parameters based on in-cloud cloud water/ice - ! these calculations also ensure consistency between number and mixing ratio - !*************************************************************************** - ! cloud ice - if (qiic(i,k).ge.qsmall) then - - ! add upper limit to in-cloud number concentration to prevent numerical error - niic(i,k)=min(niic(i,k),qiic(i,k)*1.e20_r8) - lami(k) = (gamma(1._r8+di)*ci* & - niic(i,k)/qiic(i,k))**(1._r8/di) - n0i(k) = niic(i,k)*lami(k) - - ! check for slope - lammax = 1._r8/10.e-6_r8 - lammin = 1._r8/(2._r8*dcs) - - ! adjust vars - if (lami(k).lt.lammin) then - lami(k) = lammin - n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*gamma(1._r8+di)) - niic(i,k) = n0i(k)/lami(k) - else if (lami(k).gt.lammax) then - lami(k) = lammax - n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*gamma(1._r8+di)) - niic(i,k) = n0i(k)/lami(k) - end if - else - lami(k) = 0._r8 - n0i(k) = 0._r8 - end if - - ! cloud water - if (qcic(i,k).ge.qsmall) then - - ! add upper limit to in-cloud number concentration to prevent numerical error - ncic(i,k)=min(ncic(i,k),qcic(i,k)*1.e20_r8) - - ! get pgam from fit to observations of martin et al. 1994 - - pgam(i,k)=0.0005714_r8*(ncic(i,k)/1.e6_r8/rho(i,k))+0.2714_r8 - pgam(i,k)=1._r8/(pgam(i,k)**2)-1._r8 - pgam(i,k)=max(pgam(i,k),2._r8) - pgam(i,k)=min(pgam(i,k),15._r8) - - ! calculate lamc - lamc(i,k) = (pi/6._r8*rhow*ncic(i,k)*gamma(pgam(i,k)+4._r8)/ & - (qcic(i,k)*gamma(pgam(i,k)+1._r8)))**(1._r8/3._r8) - - ! lammin, 50 micron diameter max mean size - lammin = (pgam(i,k)+1._r8)/40.e-6_r8 - lammax = (pgam(i,k)+1._r8)/1.e-6_r8 - - if (lamc(i,k).lt.lammin) then - lamc(i,k) = lammin - ncic(i,k) = 6._r8*lamc(i,k)**3*qcic(i,k)* & - gamma(pgam(i,k)+1._r8)/ & - (pi*rhow*gamma(pgam(i,k)+4._r8)) - else if (lamc(i,k).gt.lammax) then - lamc(i,k) = lammax - ncic(i,k) = 6._r8*lamc(i,k)**3*qcic(i,k)* & - gamma(pgam(i,k)+1._r8)/ & - (pi*rhow*gamma(pgam(i,k)+4._r8)) - end if - - ! parameter to calculate droplet freezing - - cdist1(k) = ncic(i,k)/gamma(pgam(i,k)+1._r8) - else - lamc(i,k) = 0._r8 - cdist1(k) = 0._r8 - end if - - ! boundary condition for cloud liquid water - if ( kqc(i) .eq. k ) then - qc(i,k) = 0._r8 - nc(i,k) = 0._r8 - end if - - ! boundary condition for cloud ice - if (kqi(i).eq.k ) then - qi(i,k) = 0._r8 - ni(i,k) = 0._r8 - end if - - !************************************************************************** - ! begin micropysical process calculations - !************************************************************************** - - !................................................................. - ! autoconversion of cloud liquid water to rain - ! formula from Khrouditnov and Kogan (2000) - ! minimum qc of 1 x 10^-8 prevents floating point error - - if (qcic(i,k).ge.1.e-8_r8) then - - ! nprc is increase in rain number conc due to autoconversion - ! nprc1 is decrease in cloud droplet conc due to autoconversion - ! Khrouditnov and Kogan (2000) -! prc(k) = 1350._r8*qcic(i,k)**2.47_r8* & -! (ncic(i,k)/1.e6_r8*rho(i,k))**(-1.79_r8) - - ! Liu and Daum(2004)(modified), Wood(2005) - rmean = 1.e6_r8*((qcic(i,k)/ncic(i,k))/(4._r8/3._r8*pi*rhow))**(1._r8/3._r8) - - if (rmean .ge. 15._r8) then - - beta6 = (1._r8+3._r8/rmean)**(1._r8/3._r8) - beta66 = (1._r8+3._r8/rmean)**2._r8 - r6 = beta6*rmean - r6c = 7.5_r8/(r6**0.5_r8*(qcic(i,k)*rho(i,k))**(1._r8/6._r8)) - prc(k) = 1.3e9_r8*beta66*(qcic(i,k)*rho(i,k))**3._r8/ & - (ncic(i,k)*rho(i,k))*max(0._r8,r6-r6c)/rho(i,k) - - nprc1(k) = prc(k)/(qcic(i,k)/ncic(i,k)) - nprc(k) = nprc1(k)*0.5_r8 - else - prc(k)=0._r8 - nprc(k)=0._r8 - nprc1(k)=0._r8 - end if - else - prc(k)=0._r8 - nprc(k)=0._r8 - nprc1(k)=0._r8 - end if - - ! provisional rain mixing ratio and number concentration (qric and nric) - ! at boundary are estimated via autoconversion - - if (k.eq.kqc(i) .and. it.eq.1) then - qric(i,k) = prc(k)*dz(i,k)/0.55_r8 - nric(i,k) = nprc(k)*dz(i,k)/0.55_r8 - qr(i,k) = 0.0_r8 - nr(i,k) = 0.0_r8 - end if - - !....................................................................... - ! Autoconversion of cloud ice to snow - ! similar to Ferrier (1994) - - call ice_autoconversion(t(i,k), qiic(i,k), lami(k), n0i(k), dcs, prci(k), nprci(k), 1) - - ! provisional snow mixing ratio and number concentration (qniic and nsic) - ! at boundary are estimated via autoconversion - - if (k.eq.kqi(i) .and. it.eq.1) then - qniic(i,k)= prci(k)*dz(i,k)*0.25_r8 - nsic(i,k)= nprci(k)*dz(i,k)*0.25_r8 - qni(i,k)= 0.0_r8 - ns(i,k)= 0.0_r8 - end if - - ! if precip mix ratio is zero so should number concentration - if (qniic(i,k).lt.qsmall) then - qniic(i,k)=0._r8 - nsic(i,k)=0._r8 - end if - if (qric(i,k).lt.qsmall) then - qric(i,k)=0._r8 - nric(i,k)=0._r8 - end if - - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - nric(i,k)=max(nric(i,k),0._r8) - nsic(i,k)=max(nsic(i,k),0._r8) - - !********************************************************************** - ! get size distribution parameters for precip - !********************************************************************** - ! rain - - if (qric(i,k).ge.qsmall) then - lamr(k) = (pi*rhow*nric(i,k)/qric(i,k))**(1._r8/3._r8) - n0r(k) = nric(i,k)*lamr(k) - - ! check for slope - lammax = 1._r8/150.e-6_r8 - lammin = 1._r8/3000.e-6_r8 - - ! adjust vars - if (lamr(k).lt.lammin) then - lamr(k) = lammin - n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow) - nric(i,k) = n0r(k)/lamr(k) - else if (lamr(k).gt.lammax) then - lamr(k) = lammax - n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow) - nric(i,k) = n0r(k)/lamr(k) - end if - - ! provisional rain number and mass weighted mean fallspeed (m/s) - ! Eq.18 of Morrison and Gettelman, 2008, J. Climate - unr(k) = min(arn(i,k)*gamma(1._r8+br)/lamr(k)**br,10._r8) - umr(k) = min(arn(i,k)*gamma(4._r8+br)/(6._r8*lamr(k)**br),10._r8) - else - lamr(k) = 0._r8 - n0r(k) = 0._r8 - umr(k) = 0._r8 - unr(k) = 0._r8 - end if - - !...................................................................... - ! snow - if (qniic(i,k).ge.qsmall) then - lams(k) = (gamma(1._r8+ds)*cs*nsic(i,k)/ & - qniic(i,k))**(1._r8/ds) - n0s(k) = nsic(i,k)*lams(k) - - ! check for slope - lammax = 1._r8/10.e-6_r8 - lammin = 1._r8/2000.e-6_r8 - - ! adjust vars - if (lams(k).lt.lammin) then - lams(k) = lammin - n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*gamma(1._r8+ds)) - nsic(i,k) = n0s(k)/lams(k) - else if (lams(k).gt.lammax) then - lams(k) = lammax - n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*gamma(1._r8+ds)) - nsic(i,k) = n0s(k)/lams(k) - end if - - ! provisional snow number and mass weighted mean fallspeed (m/s) - ums(k) = min(asn(i,k)*gamma(4._r8+bs)/(6._r8*lams(k)**bs),3.6_r8) - uns(k) = min(asn(i,k)*gamma(1._r8+bs)/lams(k)**bs,3.6_r8) - else - lams(k) = 0._r8 - n0s(k) = 0._r8 - ums(k) = 0._r8 - uns(k) = 0._r8 - end if - - !....................................................................... - ! snow self-aggregation from passarelli, 1978, used by Reisner(1998,Eq.A.35) - ! this is hard-wired for bs = 0.4 for now - ! ignore self-collection of cloud ice - - call snow_self_aggregation(t(i,k), rho(i,k), asn(i,k), rhosn, qniic(i,k), nsic(i,k), nsagg(k), 1) - - !....................................................................... - ! accretion of cloud droplets onto snow/graupel - ! here use continuous collection equation with - ! simple gravitational collection kernel - ! ignore collisions between droplets/cloud ice - - ! ignore collision of snow with droplets above freezing - - call accrete_cloud_water_snow(t(i,k), rho(i,k), asn(i,k), uns(k), mua(i,k), & - qcic(i,k), ncic(i,k), qniic(i,k), pgam(i,k), lamc(i,k), lams(k), n0s(k), & - psacws(k), npsacws(k), 1) - - ! secondary ice production due to accretion of droplets by snow - ! (Hallet-Mossop process) (from Cotton et al., 1986) - - call secondary_ice_production(t(i,k), psacws(k), msacwi(k), nsacwi(k), 1) - - !....................................................................... - ! accretion of rain water by snow - ! formula from ikawa and saito, 1991, used by reisner et al., 1998 - - call accrete_rain_snow(t(i,k), rho(i,k), umr(k), ums(k), unr(k), uns(k), qric(i,k), & - qniic(i,k), lamr(k), n0r(k), lams(k), n0s(k), pracs(k), npracs(k), 1 ) - - !....................................................................... - ! heterogeneous freezing of rain drops - ! follows from Bigg (1953) - - call heterogeneous_rain_freezing(t(i,k), qric(i,k), nric(i,k), lamr(k), mnuccr(k), nnuccr(k), 1) - - !....................................................................... - ! accretion of cloud liquid water by rain - ! formula from Khrouditnov and Kogan (2000) - ! gravitational collection kernel, droplet fall speed neglected - - call accrete_cloud_water_rain(.true., qric(i,k), qcic(i,k), ncic(i,k), [1._r8], [0._r8], pra(k), npra(k), 1) - - !....................................................................... - ! Self-collection of rain drops - ! from Beheng(1994) - - call self_collection_rain(rho(i,k), qric(i,k), nric(i,k), nragg(k), 1) - - !....................................................................... - ! Accretion of cloud ice by snow - ! For this calculation, it is assumed that the Vs >> Vi - ! and Ds >> Di for continuous collection - - call accrete_cloud_ice_snow(t(i,k), rho(i,k), asn(i,k), qiic(i,k), niic(i,k), & - qniic(i,k), lams(k), n0s(k), prai(k), nprai(k), 1) - - !....................................................................... - ! fallout term - prf(k) = -umr(k)*qric(i,k)/dz(i,k) - pnrf(k) = -unr(k)*nric(i,k)/dz(i,k) - psf(k) = -ums(k)*qniic(i,k)/dz(i,k) - pnsf(k) = -uns(k)*nsic(i,k)/dz(i,k) - - !........................................................................ - ! calculate vertical velocity in cumulus updraft - - if (k.eq.jb(i)) then - zkine(i,jb(i)) = 0.5_r8 - wu (i,jb(i)) = 1._r8 - zbuo (i,jb(i)) = (tu(i,jb(i))*(1._r8+retv*qu(i,jb(i)))- & - th(i,jb(i))*(1._r8+retv*qh(i,jb(i))))/ & - (th(i,jb(i))*(1._r8+retv*qh(i,jb(i)))) - else - if (.true.) then - ! ECMWF formula - zbc = tu(i,k)*(1._r8+retv*qu(i,k)-qr(i,k)-qni(i,k)-qi(i,k)-qc(i,k)) - zbe = th(i,k)*(1._r8+retv*qh(i,k)) - zbuo(i,k) = (zbc-zbe)/zbe - zbuoc= (zbuo(i,k)+zbuo(i,k+1))*0.5_r8 - zdkbuo = dz(i,k+1)*grav*zfacbuo*zbuoc - zdken = min(.99_r8,(1._r8+cwdrag)*max(du(i,k),eu(i,k))*dz(i,k+1)/ & - max(1.e-10_r8,mu(i,k+1))) - zkine(i,k) = (zkine(i,k+1)*(1._r8-zdken)+zdkbuo)/ & - (1._r8+zdken) - else - ! Gregory formula - zbc = tu(i,k)*(1._r8+retv*qu(i,k)) - zbe = th(i,k)*(1._r8+retv*qh(i,k)) - zbuo(i,k) = (zbc-zbe)/zbe-qr(i,k)-qni(i,k)-qi(i,k)-qc(i,k) - zbuoc= (zbuo(i,k)+zbuo(i,k+1))*0.5_r8 - zdkbuo = dz(i,k+1)*grav*zbuoc*(1.0_r8-0.25_r8)/6._r8 - zdken = du(i,k)*dz(i,k+1)/max(1.e-10_r8,mu(i,k+1)) - zkine(i,k) = (zkine(i,k+1)*(1._r8-zdken)+zdkbuo)/ & - (1._r8+zdken) - end if - wu(i,k) = min(15._r8,sqrt(2._r8*max(0.1_r8,zkine(i,k) ))) - end if - - arcf(i,k)= mu(i,k)/wu(i,k) - - !............................................................................ - ! droplet activation - ! calculate potential for droplet activation if cloud water is present - ! formulation from Abdul-Razzak and Ghan (2000) and Abdul-Razzak et al. (1998), AR98 - - if (aero%scheme == 'bulk') then - naer2h(i,k,:) = 0.5_r8*(naer2(i,k,:) + naer2(i,k-1,:)) - end if - - ntaerh(i,k) = 0.5_r8*(ntaer(i,k) + ntaer(i,k-1)) - - if (qcic(i,k).ge.qsmall ) then - - if (aero%scheme == 'modal') then - - nlsrc = 0._r8 - - do m = 1, aero%nmodes - vaerosol(m) = 0._r8 - hygro(m) = 0._r8 - do l = 1, aero%nspec(m) - vol = max(0.5_r8*(aero%mmrg_a(i,k,l,m)+aero%mmrg_a(i,k-1,l,m)) , 0._r8)/aero%specdens(l,m) - vaerosol(m) = vaerosol(m) + vol - hygro(m) = hygro(m) + vol*aero%spechygro(l,m) - end do - if (vaerosol(m) > 1.0e-30_r8) then - hygro(m) = hygro(m)/(vaerosol(m)) - vaerosol(m) = vaerosol(m)*rho(i,k) - else - hygro(m) = 0.0_r8 - vaerosol(m) = 0.0_r8 - endif - naermod(m) = 0.5_r8*(aero%numg_a(i,k,m)+aero%numg_a(i,k-1,m))*rho(i,k) - naermod(m) = max(naermod(m), vaerosol(m)*aero%voltonumbhi(m)) - naermod(m) = min(naermod(m), vaerosol(m)*aero%voltonumblo(m)) - end do - - in_cloud = (k < jb(i)) - smax_f = 0.0_r8 - if (in_cloud) then - if ( qcic(i,k).ge.qsmall ) & - smax_f = ncic(i,k)/lamc(i,k) * gamma(2.0_r8 + pgam(i,k))/gamma(1.0_r8 + pgam(i,k)) - if ( qric(i,k).ge.qsmall) smax_f = smax_f + nric(i,k)/lamr(k) - - end if - - call activate_aerosol( & - wu(i,k), wmix, wdiab, wmin, wmax, & - t(i,k), rho(i,k), naermod, aero%nmodes, vaerosol, & - hygro, aero_props_obj, fn, fm, & - fluxn, fluxm, flux_fullact, in_cloud_in=in_cloud, smax_f=smax_f) - - do m = 1, aero%nmodes - nlsrc = nlsrc + fn(m)*naermod(m) ! number nucleated - end do - - if (nlsrc .ne. nlsrc) then - write(iulog,*) "nlsrc=",nlsrc,"wu(i,k)=",wu(i,k) - write(iulog,*) "fn(m)=",fn,"naermod(m)=",naermod,"aero%specdens(l,m)=",aero%specdens - write(iulog,*) "vaerosol(m)=",vaerosol,"aero%voltonumbhi(m)=",aero%voltonumbhi - write(iulog,*) "aero%voltonumblo(m)=",aero%voltonumblo,"k=",k,"i=",i - write(iulog,*) "aero%numg_a(i,k,m)=",aero%numg_a(i,k,:),"rho(i,k)=",rho(i,k) - write(iulog,*) "aero%mmrg_a(i,k,l,m)=",aero%mmrg_a(i,k,:,:) - end if - - dum2l(i,k) = nlsrc - - else if (aero%scheme == 'bulk') then - - call ndrop_bam_run( & - wu(i,k), t(i,k), rho(i,k), naer2h(i,k,:), aero%nbulk, & - aero%nbulk, maerosol, dum2) - - dum2l(i,k) = dum2 - - end if - - else - dum2l(i,k) = 0._r8 - end if - - ! get droplet activation rate - if (qcic(i,k).ge.qsmall .and. t(i,k).gt.238.15_r8 .and. k.gt.jt(i)+2 ) then - - ! assume aerosols already activated are equal number of existing droplets for simplicity - if (k.eq.kqc(i)) then - npccn(k) = dum2l(i,k)/deltat - else - npccn(k) = (dum2l(i,k)-ncic(i,k))/deltat - end if - - ! make sure number activated > 0 - npccn(k) = max(0._r8,npccn(k)) - ncmax = dum2l(i,k) - else - npccn(k)=0._r8 - ncmax = 0._r8 - end if - - !.............................................................................. - !ice nucleation - es(i,k) = svp_water(t(i,k)) ! over water in mixed clouds - esi(i,k) = svp_ice(t(i,k)) ! over ice - qs(i,k) = 0.622_r8*es(i,k)/(ph(i,k) - (1.0_r8-0.622_r8)*es(i,k)) - qs(i,k) = min(1.0_r8,qs(i,k)) - if (qs(i,k) < 0.0_r8) qs(i,k) = 1.0_r8 - - relhum(i,k)= 1.0_r8 - - if (t(i,k).lt.tmelt ) then - - ! compute aerosol number for so4, soot, and dust with units #/cm^3 - so4_num = 0._r8 - soot_num = 0._r8 - dst1_num = 0._r8 - dst2_num = 0._r8 - dst3_num = 0._r8 - dst4_num = 0._r8 - - if (aero%scheme == 'modal') then - - !For modal aerosols, assume for the upper troposphere: - ! soot = accumulation mode - ! sulfate = aiken mode - ! dust = coarse mode - ! since modal has internal mixtures. - soot_num = 0.5_r8*(aero%numg_a(i,k-1,aero%mode_accum_idx) & - +aero%numg_a(i,k,aero%mode_accum_idx))*rho(i,k)*1.0e-6_r8 - dmc = 0.5_r8*(aero%mmrg_a(i,k-1,aero%coarse_dust_idx,aero%mode_coarse_idx) & - +aero%mmrg_a(i,k,aero%coarse_dust_idx,aero%mode_coarse_idx)) - ssmc = 0.5_r8*(aero%mmrg_a(i,k-1,aero%coarse_nacl_idx,aero%mode_coarse_idx) & - +aero%mmrg_a(i,k,aero%coarse_nacl_idx,aero%mode_coarse_idx)) - if (dmc > 0._r8) then - dst_num = dmc/(ssmc + dmc) *(aero%numg_a(i,k-1,aero%mode_coarse_idx) & - + aero%numg_a(i,k,aero%mode_coarse_idx))*0.5_r8*rho(i,k)*1.0e-6_r8 - else - dst_num = 0.0_r8 - end if - dgnum_aitken = 0.5_r8*(aero%dgnumg(i,k,aero%mode_aitken_idx)+ & - aero%dgnumg(i,k-1,aero%mode_aitken_idx)) - if (dgnum_aitken > 0._r8) then - ! only allow so4 with D>0.1 um in ice nucleation - so4_num = 0.5_r8*(aero%numg_a(i,k-1,aero%mode_aitken_idx)+ & - aero%numg_a(i,k,aero%mode_aitken_idx))*rho(i,k)*1.0e-6_r8 & - * (0.5_r8 - 0.5_r8*erf(log(0.1e-6_r8/dgnum_aitken)/ & - (2._r8**0.5_r8*log(aero%sigmag_aitken)))) - else - so4_num = 0.0_r8 - end if - so4_num = max(0.0_r8, so4_num) - - else if (aero%scheme == 'bulk') then - - if (aero%idxsul > 0) then - so4_num = naer2h(i,k,aero%idxsul)/25._r8 *1.0e-6_r8 - end if - if (aero%idxbcphi > 0) then - soot_num = naer2h(i,k,aero%idxbcphi)/25._r8 *1.0e-6_r8 - end if - if (aero%idxdst1 > 0) then - dst1_num = naer2h(i,k,aero%idxdst1)/25._r8 *1.0e-6_r8 - end if - if (aero%idxdst2 > 0) then - dst2_num = naer2h(i,k,aero%idxdst2)/25._r8 *1.0e-6_r8 - end if - if (aero%idxdst3 > 0) then - dst3_num = naer2h(i,k,aero%idxdst3)/25._r8 *1.0e-6_r8 - end if - if (aero%idxdst4 > 0) then - dst4_num = naer2h(i,k,aero%idxdst4)/25._r8 *1.0e-6_r8 - end if - dst_num = dst1_num + dst2_num + dst3_num + dst4_num - - end if - - ! *** Turn off soot nucleation *** - soot_num = 0.0_r8 - - ! Liu et al.,J. climate, 2007 - if ( wu(i,k) .lt. 4.0_r8) then - call nucleati( & - wu(i,k), t(i,k), ph(i,k), relhum(i,k), 1.0_r8, qcic(i,k), & - 1.0e-20_r8, 0.0_r8, rho(i,k), so4_num, dst_num, soot_num, 1.0_r8, & - dum2i(i,k), nihf(i,k), niimm(i,k), nidep(i,k), nimey(i,k), & - wpice, weff, fhom, temp1, temp2, temp3, temp4, .true. ) - end if - nihf(i,k)=nihf(i,k)*rho(i,k) ! convert from #/kg -> #/m3) - niimm(i,k)=niimm(i,k)*rho(i,k) - nidep(i,k)=nidep(i,k)*rho(i,k) - nimey(i,k)=nimey(i,k)*rho(i,k) - - if (.false.) then - ! cooper curve (factor of 1000 is to convert from L-1 to m-3) - !dum2i(i,k)=0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k)))*1000._r8 - - ! put limit on number of nucleated crystals, set to number at T=-30 C - ! cooper (limit to value at -35 C) - !dum2i(i,k)=min(dum2i(i,k),208.9e3_r8)/rho(i,k) ! convert from m-3 to kg-1 - end if - - else - dum2i(i,k)=0._r8 - end if - - ! ice nucleation if activated nuclei exist at t<0C - - if (dum2i(i,k).gt.0._r8.and.t(i,k).lt.tmelt.and. & - relhum(i,k)*es(i,k)/esi(i,k).gt. 1.05_r8 .and. k.gt.jt(i)+1) then - - if (k.eq.kqi(i)) then - nnuccd(k)=dum2i(i,k)/deltat - else - nnuccd(k)=(dum2i(i,k)-niic(i,k))/deltat - end if - nnuccd(k)=max(nnuccd(k),0._r8) - - !Calc mass of new particles using new crystal mass... - !also this will be multiplied by mtime as nnuccd is... - - mnuccd(k) = nnuccd(k) * mi0 - else - nnuccd(k)=0._r8 - mnuccd(k) = 0._r8 - end if - - !................................................................................ - ! Bergeron process - ! If 0C< T <-40C and both ice and liquid exist - - if (t(i,k).le.273.15_r8 .and. t(i,k).gt.233.15_r8 .and. & - qiic(i,k).gt.0.5e-6_r8 .and. qcic(i,k).gt. qsmall) then - plevap = qcic(i,k)/bergtsf - prb(k) = max(0._r8,plevap) - nprb(k) = prb(k)/(qcic(i,k)/ncic(i,k)) - else - prb(k)=0._r8 - nprb(k)=0._r8 - end if - - !................................................................................ - ! heterogeneous freezing of cloud water (-5C < T < -35C) - - if (qcic(i,k).ge.qsmall .and.ncic(i,k).gt.0._r8 .and. ntaerh(i,k).gt.0._r8 .and. & - t(i,k).le.268.15_r8 .and. t(i,k).gt.238.15_r8 ) then - - if (aero%scheme == 'bulk') then - ! immersion freezing (Diehl and Wurzler, 2004) - ttend(k) = -grav*wu(i,k)/cp/(1.0_r8+gamhat(i,k)) - - nai_bcphi = 0.0_r8 - nai_dst1 = 0.0_r8 - nai_dst2 = 0.0_r8 - nai_dst3 = 0.0_r8 - nai_dst4 = 0.0_r8 - - if (aero%idxbcphi > 0) nai_bcphi = naer2h(i,k,aero%idxbcphi) - if (aero%idxdst1 > 0) nai_dst1 = naer2h(i,k,aero%idxdst1) - if (aero%idxdst2 > 0) nai_dst2 = naer2h(i,k,aero%idxdst2) - if (aero%idxdst3 > 0) nai_dst3 = naer2h(i,k,aero%idxdst3) - if (aero%idxdst4 > 0) nai_dst4 = naer2h(i,k,aero%idxdst4) - - naimm = (0.00291_r8*nai_bcphi + 32.3_r8*(nai_dst1 + nai_dst2 + & - nai_dst3 + nai_dst4))/ntaerh(i,k) !m-3 - if (ttend(k) .lt. 0._r8) then - nnuccc(k) = -naimm*exp(273.15_r8-t(i,k))*ttend(k)*qcic(i,k)/rhow ! kg-1s-1 - mnuccc(k) = nnuccc(k)*qcic(i,k)/ncic(i,k) - end if - else - if (.false.) then - ! immersion freezing (Diehl and Wurzler, 2004) - ttend(k) = -grav*wu(i,k)/cp/(1.0_r8+gamhat(i,k)) - naimm = (0.00291_r8*soot_num + 32.3_r8*dst_num )*1.0e6_r8/ntaerh(i,k) !m-3 - if (ttend(k) .lt. 0._r8) then - nnuccc(k) = -naimm*exp(273.15_r8-t(i,k))*ttend(k)*qcic(i,k)/rhow ! kg-1s-1 - mnuccc(k) = nnuccc(k)*qcic(i,k)/ncic(i,k) - end if - else - ! immersion freezing (Bigg, 1953) - mnuccc(k) = pi*pi/36._r8*rhow* & - cdist1(k)*gamma(7._r8+pgam(i,k))* & - bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/ & - lamc(i,k)**3/lamc(i,k)**3 - - nnuccc(k) = pi/6._r8*cdist1(k)*gamma(pgam(i,k)+4._r8) & - *bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/lamc(i,k)**3 - end if - end if - - ! contact freezing (Young, 1974) with hooks into simulated dust - - tcnt=(270.16_r8-t(i,k))**1.3_r8 - viscosity=1.8e-5_r8*(t(i,k)/298.0_r8)**0.85_r8 ! Viscosity (kg/m/s) - mfp=2.0_r8*viscosity/(ph(i,k) & ! Mean free path (m) - *sqrt(8.0_r8*28.96e-3_r8/(pi*8.314409_r8*t(i,k)))) - - slip1=1.0_r8+(mfp/rn_dst1)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst1/mfp))))! Slip correction factor - slip2=1.0_r8+(mfp/rn_dst2)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst2/mfp)))) - slip3=1.0_r8+(mfp/rn_dst3)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst3/mfp)))) - slip4=1.0_r8+(mfp/rn_dst4)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst4/mfp)))) - - dfaer1=1.381e-23_r8*t(i,k)*slip1/(6._r8*pi*viscosity*rn_dst1) ! aerosol diffusivity (m2/s) - dfaer2=1.381e-23_r8*t(i,k)*slip2/(6._r8*pi*viscosity*rn_dst2) - dfaer3=1.381e-23_r8*t(i,k)*slip3/(6._r8*pi*viscosity*rn_dst3) - dfaer4=1.381e-23_r8*t(i,k)*slip4/(6._r8*pi*viscosity*rn_dst4) - - nacon1=0.0_r8 - nacon2=0.0_r8 - nacon3=0.0_r8 - nacon4=0.0_r8 - - if (aero%scheme == 'modal') then - - ! For modal aerosols: - ! use size '3' for dust coarse mode... - ! scale by dust fraction in coarse mode - - dmc = 0.5_r8*(aero%mmrg_a(i,k,aero%coarse_dust_idx,aero%mode_coarse_idx) & - +aero%mmrg_a(i,k-1,aero%coarse_dust_idx,aero%mode_coarse_idx)) - ssmc = 0.5_r8*(aero%mmrg_a(i,k,aero%coarse_nacl_idx,aero%mode_coarse_idx) & - +aero%mmrg_a(i,k-1,aero%coarse_nacl_idx,aero%mode_coarse_idx)) - if (dmc > 0.0_r8) then - nacon3 = dmc/(ssmc + dmc) * (aero%numg_a(i,k,aero%mode_coarse_idx) & - + aero%numg_a(i,k-1,aero%mode_coarse_idx))*0.5_r8*rho(i,k) - end if - - else if (aero%scheme == 'bulk') then - - if (aero%idxdst1.gt.0) then - nacon1=naer2h(i,k,aero%idxdst1)*tcnt *0.0_r8 - endif - if (aero%idxdst2.gt.0) then - nacon2=naer2h(i,k,aero%idxdst2)*tcnt ! 1/m3 - endif - if (aero%idxdst3.gt.0) then - nacon3=naer2h(i,k,aero%idxdst3)*tcnt - endif - if (aero%idxdst4.gt.0) then - nacon4=naer2h(i,k,aero%idxdst4)*tcnt - endif - end if - - mnucct(k) = (dfaer1*nacon1+dfaer2*nacon2+dfaer3*nacon3+dfaer4*nacon4)*pi*pi/3._r8*rhow* & - cdist1(k)*gamma(pgam(i,k)+5._r8)/lamc(i,k)**4 - - nnucct(k) = (dfaer1*nacon1+dfaer2*nacon2+dfaer3*nacon3+dfaer4*nacon4)*2._r8*pi* & - cdist1(k)*gamma(pgam(i,k)+2._r8)/lamc(i,k) - - ! if (nnuccc(k).gt.nnuccd(k)) then - ! dum=nnuccd(k)/nnuccc(k) - ! scale mixing ratio of droplet freezing with limit - ! mnuccc(k)=mnuccc(k)*dum - ! nnuccc(k)=nnuccd(k) - ! end if - - else - mnuccc(k) = 0._r8 - nnuccc(k) = 0._r8 - mnucct(k) = 0._r8 - nnucct(k) = 0._r8 - end if - - ! freeze cloud liquid water homogeneously at -40 C - if (t(i,k) < 233.15_r8 .and. qc(i,k) > 0._r8) then - - ! make sure freezing rain doesn't increase temperature above - ! threshold - dum = xlf/cp*qc(i,k) - if (t(i,k)+dum.gt.233.15_r8) then - dum = -(t(i,k)-233.15_r8)*cp/xlf - dum = dum/qc(i,k) - dum = max(0._r8,dum) - dum = min(1._r8,dum) - else - dum = 1._r8 - end if - fholm(i,k) = mu(i,k)*dum*qc(i,k) - fholn(i,k) = mu(i,k)*dum*nc(i,k) - end if - - - !**************************************************************************************** - ! conservation to ensure no negative values of cloud water/precipitation - ! in case microphysical process rates are large - ! note: for check on conservation, processes are multiplied by omsm - ! to prevent problems due to round off error - - ! since activation/nucleation processes are fast, need to take into account - ! factor mtime = mixing timescale in cloud / model time step - ! for now mixing timescale is assumed to be 15 min - !***************************************************************************************** - - mtime=deltat/900._r8 - mtimec=deltat/900._r8 - - ! conservation of qc - ! ice mass production from ice nucleation(deposition/cond.-freezing), mnuccd, - ! is considered as a part of cmei. - - qce = mu(i,k)*qc(i,k)-fholm(i,k) +dz(i,k)*cmel(i,k-1) - dum = arcf(i,k)*(pra(k)+prc(k)+prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)+ & - psacws(k))*dz(i,k) - if( qce.lt.0._r8) then - qcimp(k) = .true. - prc(k) = 0._r8 - pra(k) = 0._r8 - prb(k) = 0._r8 - mnuccc(k) = 0._r8 - mnucct(k) = 0._r8 - msacwi(k) = 0._r8 - psacws(k) = 0._r8 - else if (dum.gt.qce) then - ratio = qce/dum*omsm - prc(k) = prc(k)*ratio - pra(k) = pra(k)*ratio - prb(k) = prb(k)*ratio - mnuccc(k) = mnuccc(k)*ratio - mnucct(k) = mnucct(k)*ratio - msacwi(k) = msacwi(k)*ratio - psacws(k) = psacws(k)*ratio - end if - - ! conservation of nc - nce = mu(i,k)*nc(i,k)-fholn(i,k) + (arcf(i,k)*npccn(k)*mtimec)*dz(i,k) - dum = arcf(i,k)*dz(i,k)*(nprc1(k)+npra(k)+nnuccc(k)+nnucct(k)+ & - npsacws(k)+ nprb(k) ) - if (nce.lt.0._r8) then - ncimp(k) = .true. - nprc1(k) = 0._r8 - npra(k) = 0._r8 - nnuccc(k) = 0._r8 - nnucct(k) = 0._r8 - npsacws(k) = 0._r8 - nprb(k) = 0._r8 - else if (dum.gt.nce) then - ratio = nce/dum*omsm - nprc1(k) = nprc1(k)*ratio - npra(k) = npra(k)*ratio - nnuccc(k) = nnuccc(k)*ratio - nnucct(k) = nnucct(k)*ratio - npsacws(k) = npsacws(k)*ratio - nprb(k) = nprb(k)*ratio - end if - - ! conservation of qi - qie = mu(i,k)*qi(i,k)+fholm(i,k) +dz(i,k)*(cmei(i,k-1) + & - ( mnuccc(k)+mnucct(k)+msacwi(k)+prb(k))*arcf(i,k) ) - dum = arcf(i,k)*(prci(k)+ prai(k))*dz(i,k) - if (qie.lt.0._r8) then - qiimp(k) = .true. - prci(k) = 0._r8 - prai(k) = 0._r8 - else if (dum.gt.qie) then - ratio = qie/dum*omsm - prci(k) = prci(k)*ratio - prai(k) = prai(k)*ratio - end if - - ! conservation of ni - nie = mu(i,k)*ni(i,k)+fholn(i,k) +dz(i,k)*(nnuccd(k)*mtime*arcf(i,k) & - +(nnuccc(k)+ nnucct(k))*arcf(i,k) ) - dum = arcf(i,k)*dz(i,k)*(-nsacwi(k)+nprci(k)+ nprai(k)) - if( nie.lt.0._r8) then - niimp(k) = .true. - nsacwi(k)= 0._r8 - nprci(k) = 0._r8 - nprai(k) = 0._r8 - else if (dum.gt.nie) then - ratio = nie/dum*omsm - nsacwi(k)= nsacwi(k)*ratio - nprci(k) = nprci(k)*ratio - nprai(k) = nprai(k)*ratio - end if - - ! conservation of qr - - qre = mu(i,k)*qr(i,k)+dz(i,k)*(pra(k)+prc(k))*arcf(i,k) - dum = arcf(i,k)*dz(i,k)*(pracs(k)+ mnuccr(k)-prf(k)) - if (qre.lt.0._r8) then - prf(k) = 0._r8 - pracs(k) = 0._r8 - mnuccr(k) = 0._r8 - else if (dum.gt.qre) then - ratio = qre/dum*omsm - prf(k) = prf(k)*ratio - pracs(k) = pracs(k)*ratio - mnuccr(k) = mnuccr(k)*ratio - end if - - ! conservation of nr - nre = mu(i,k)*nr(i,k) + nprc(k)*arcf(i,k)*dz(i,k) - dum = arcf(i,k)*dz(i,k)*(npracs(k)+nnuccr(k) & - -nragg(k)-pnrf(k)) - if(nre.lt.0._r8) then - npracs(k)= 0._r8 - nnuccr(k)= 0._r8 - nragg(k) = 0._r8 - pnrf(k) = 0._r8 - else if (dum.gt.nre) then - ratio = nre/dum*omsm - npracs(k)= npracs(k)*ratio - nnuccr(k)= nnuccr(k)*ratio - nragg(k) = nragg(k)*ratio - pnrf(k) = pnrf(k)*ratio - end if - - ! conservation of qni - - qnie = mu(i,k)*qni(i,k)+dz(i,k)*( (prai(k)+psacws(k)+prci(k)+ & - pracs(k)+mnuccr(k))*arcf(i,k) ) - dum = arcf(i,k)*dz(i,k)*(-psf(k)) - - if(qnie.lt.0._r8) then - psf(k) = 0._r8 - else if (dum.gt.qnie) then - ratio = qnie/dum*omsm - psf(k) = psf(k)*ratio - end if - - ! conservation of ns - nse = mu(i,k)*ns(i,k)+dz(i,k)*(nprci(k)+nnuccr(k))*arcf(i,k) - dum = arcf(i,k)*dz(i,k)*(-nsagg(k)-pnsf(k)) - if (nse.lt.0._r8) then - nsagg(k) = 0._r8 - pnsf(k) = 0._r8 - else if (dum.gt.nse) then - ratio = nse/dum*omsm - nsagg(k) = nsagg(k)*ratio - pnsf(k) = pnsf(k)*ratio - end if - - !***************************************************************************** - ! get tendencies due to microphysical conversion processes - !***************************************************************************** - - if (k.le.kqc(i)) then - qctend(i,k) = (-pra(k)-prc(k)-prb(k)-mnuccc(k)-mnucct(k)-msacwi(k)- & - psacws(k)) - - qitend(i,k) = (prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)-prci(k)- prai(k)) - - qrtend(i,k) = (pra(k)+prc(k))+(-pracs(k)- mnuccr(k)) - - qnitend(i,k) = (prai(k)+psacws(k)+prci(k))+(pracs(k)+mnuccr(k)) - - ! multiply activation/nucleation by mtime to account for fast timescale - - nctend(i,k) = npccn(k)*mtimec+(-nnuccc(k)-nnucct(k)-npsacws(k) & - -npra(k)-nprc1(k)-nprb(k)) - - nitend(i,k) = nnuccd(k)*mtime+(nnuccc(k)+ nnucct(k)+nsacwi(k)-nprci(k)- & - nprai(k)) - - nstend(i,k) = nsagg(k)+nnuccr(k) + nprci(k) - - nrtend(i,k) = nprc(k)+(-npracs(k)-nnuccr(k) +nragg(k)) - - ! for output - ! cloud liquid water------------- - - autolm(i,k-1) = -prc(k)*arcf(i,k) - accrlm(i,k-1) = -pra(k)*arcf(i,k) - bergnm(i,k-1) = -prb(k)*arcf(i,k) - fhtimm(i,k-1) = -mnuccc(k)*arcf(i,k) - fhtctm(i,k-1) = -mnucct(k)*arcf(i,k) - hmpim (i,k-1) = -msacwi(k)*arcf(i,k) - accslm(i,k-1) = -psacws(k)*arcf(i,k) - fhmlm(i,k-1) = -fholm(i,k)/dz(i,k) - - autoln(i,k-1) = -nprc1(k)*arcf(i,k) - accrln(i,k-1) = -npra(k)*arcf(i,k) - bergnn(i,k-1) = -nprb(k)*arcf(i,k) - fhtimn(i,k-1) = -nnuccc(k)*arcf(i,k) - fhtctn(i,k-1) = -nnucct(k)*arcf(i,k) - accsln(i,k-1) = -npsacws(k)*arcf(i,k) - activn(i,k-1) = npccn(k)*mtimec*arcf(i,k) - fhmln(i,k-1) = -fholn(i,k)/dz(i,k) - - !cloud ice------------------------ - - autoim(i,k-1) = -prci(k)*arcf(i,k) - accsim(i,k-1) = -prai(k)*arcf(i,k) - - nuclin(i,k-1) = nnuccd(k)*mtime*arcf(i,k) - autoin(i,k-1) = -nprci(k)*arcf(i,k) - accsin(i,k-1) = -nprai(k)*arcf(i,k) - hmpin (i,k-1) = nsacwi(k)*arcf(i,k) - - else - qctend(i,k) = 0._r8 - qitend(i,k) = 0._r8 - qrtend(i,k) = 0._r8 - qnitend(i,k) = 0._r8 - nctend(i,k) = 0._r8 - nitend(i,k) = 0._r8 - nstend(i,k) = 0._r8 - nrtend(i,k) = 0._r8 - end if - - !******************************************************************************** - ! vertical integration - !******************************************************************************** - ! snow - if ( k.le.kqi(i) ) then - qni(i,k-1) = 1._r8/mu(i,k-1)* & - (mu(i,k)*qni(i,k)+dz(i,k)*(qnitend(i,k)+psf(k))*arcf(i,k) ) - - ns(i,k-1) = 1._r8/mu(i,k-1)* & - (mu(i,k)*ns(i,k)+dz(i,k)*(nstend(i,k)+pnsf(k))*arcf(i,k) ) - - else - qni(i,k-1)=0._r8 - ns(i,k-1)=0._r8 - end if - - if (qni(i,k-1).le.0._r8) then - qni(i,k-1)=0._r8 - ns(i,k-1)=0._r8 - end if - - ! rain - if (k.le.kqc(i) ) then - qr(i,k-1) = 1._r8/mu(i,k-1)* & - (mu(i,k)*qr(i,k)+dz(i,k)*(qrtend(i,k)+prf(k))*arcf(i,k) ) - - nr(i,k-1) = 1._r8/mu(i,k-1)* & - (mu(i,k)*nr(i,k)+dz(i,k)*(nrtend(i,k)+pnrf(k))*arcf(i,k) ) - - else - qr(i,k-1)=0._r8 - nr(i,k-1)=0._r8 - end if - - if( qr(i,k-1) .le. 0._r8) then - qr(i,k-1)=0._r8 - nr(i,k-1)=0._r8 - end if - - ! freeze rain homogeneously at -40 C - - if (t(i,k-1) < 233.15_r8 .and. qr(i,k-1) > 0._r8) then - - ! make sure freezing rain doesn't increase temperature above threshold - dum = xlf/cp*qr(i,k-1) - if (t(i,k-1)+dum.gt.233.15_r8) then - dum = -(t(i,k-1)-233.15_r8)*cp/xlf - dum = dum/qr(i,k-1) - dum = max(0._r8,dum) - dum = min(1._r8,dum) - else - dum = 1._r8 - end if - qni(i,k-1)=qni(i,k-1)+dum*qr(i,k-1) - ns(i,k-1)=ns(i,k-1)+dum*nr(i,k-1) - qr(i,k-1)=(1._r8-dum)*qr(i,k-1) - nr(i,k-1)=(1._r8-dum)*nr(i,k-1) - fhmrm(i,k-1) = -mu(i,k-1)*dum*qr(i,k-1)/dz(i,k) - end if - - - ! cloud water - if ( k.le.kqc(i) ) then - qc(i,k-1) = (mu(i,k)*qc(i,k)-fholm(i,k)+dz(i,k)*qctend(i,k)*arcf(i,k) & - +dz(i,k)*cmel(i,k-1) )/(mu(i,k-1)+dz(i,k)*du(i,k-1)) - - qcde(i,k) = qc(i,k-1) - - nc(i,k-1) = (mu(i,k)*nc(i,k) -fholn(i,k) +dz(i,k)*nctend(i,k)*arcf(i,k) ) & - /(mu(i,k-1)+dz(i,k)*du(i,k-1)) - - ncde(i,k) = nc(i,k-1) - else - qc(i,k-1)=0._r8 - nc(i,k-1)=0._r8 - end if - - if (qc(i,k-1).lt.0._r8) write(iulog,*) "negative qc(i,k-1)=",qc(i,k-1) - dlfm(i,k-1) = -du(i,k-1)*qcde(i,k) - dlfn(i,k-1) = -du(i,k-1)*ncde(i,k) - - if (qc(i,k-1).le. 0._r8) then - qc(i,k-1)=0._r8 - nc(i,k-1)=0._r8 - end if - - if (nc(i,k-1).lt. 0._r8) then - write(iulog,*) "nc(i,k-1)=",nc(i,k-1),"k-1=",k-1,"arcf(i,k)=",arcf(i,k) - write(iulog,*) "mu(i,k-1)=",mu(i,k-1),"mu(i,k)=",mu(i,k),"nc(i,k)=",ni(i,k) - write(iulog,*) "dz(i,k)=",dz(i,k),"du(i,k-1)=",du(i,k-1),"nctend(i,k)=",nctend(i,k) - write(iulog,*) "eu(i,k-1)=",eu(i,k-1) - end if - - ! cloud ice - if( k.le.kqi(i)) then - qi(i,k-1) = (mu(i,k)*qi(i,k)+fholm(i,k) +dz(i,k)*qitend(i,k)*arcf(i,k) & - +dz(i,k)*cmei(i,k-1) )/(mu(i,k-1)+dz(i,k)*du(i,k-1)) - - qide(i,k) = qi(i,k-1) - - ni(i,k-1) = (mu(i,k)*ni(i,k)+fholn(i,k)+dz(i,k)*nitend(i,k)*arcf(i,k) ) & - /(mu(i,k-1)+dz(i,k)*du(i,k-1)) - - nide(i,k) = ni(i,k-1) - else - qi(i,k-1)=0._r8 - ni(i,k-1)=0._r8 - end if - - if (qi(i,k-1).lt.0._r8) write(iulog,*) "negative qi(i,k-1)=",qi(i,k-1) - difm(i,k-1) = -du(i,k-1)*qide(i,k) - difn(i,k-1) = -du(i,k-1)*nide(i,k) - - if (qi(i,k-1).le. 0._r8) then - qi(i,k-1)=0._r8 - ni(i,k-1)=0._r8 - end if - - - if (ni(i,k-1).lt. 0._r8) then - write(iulog,*) "ni(i,k-1)=",ni(i,k-1),"k-1=",k-1,"arcf(i,k)=",arcf(i,k) - write(iulog,*) "mu(i,k-1)=",mu(i,k-1),"mu(i,k)=",mu(i,k),"ni(i,k)=",ni(i,k) - write(iulog,*) "dz(i,k)=",dz(i,k),"du(i,k-1)=",du(i,k-1),"nitend(i,k)=",nitend(i,k) - write(iulog,*) "eu(i,k-1)=",eu(i,k-1) - end if - - - frz(i,k-1) = cmei(i,k-1) + arcf(i,k)*(prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)+ & - pracs(k)+mnuccr(k)+psacws(k) )-fhmlm(i,k-1)-fhmrm(i,k-1) - - - !****************************************************************************** - ! get size distribution parameters based on in-cloud cloud water/ice - ! these calculations also ensure consistency between number and mixing ratio - - ! following equation(2,3,4) of Morrison and Gettelman, 2008, J. Climate. - ! Gamma(n)= (n-1)! - ! lamc <-> lambda for cloud liquid water - ! pgam <-> meu for cloud liquid water - ! meu=0 for ice,rain and snow - !******************************************************************************* - - ! cloud ice - niorg = ni(i,k-1) - if (qi(i,k-1).ge.qsmall) then - - ! add upper limit to in-cloud number concentration to prevent numerical error - ni(i,k-1)=min(ni(i,k-1),qi(i,k-1)*1.e20_r8) - ! ni should be non-negative - ! ni(i,k-1) = max(ni(i,k-1), 0._r8) - if (ni(i,k-1).lt. 0._r8) write(iulog,*) "ni(i,k-1)=",ni(i,k-1) - - lami(k-1) = (gamma(1._r8+di)*ci* & - ni(i,k-1)/qi(i,k-1))**(1._r8/di) - n0i(k-1) = ni(i,k-1)*lami(k-1) - - ! check for slope - lammax = 1._r8/10.e-6_r8 - lammin = 1._r8/(2._r8*dcs) - - ! adjust vars - if (lami(k-1).lt.lammin) then - lami(k-1) = lammin - n0i(k-1) = lami(k-1)**(di+1._r8)*qi(i,k-1)/(ci*gamma(1._r8+di)) - ni(i,k-1) = n0i(k-1)/lami(k-1) - else if (lami(k-1).gt.lammax) then - lami(k-1) = lammax - n0i(k-1) = lami(k-1)**(di+1._r8)*qi(i,k-1)/(ci*gamma(1._r8+di)) - ni(i,k-1) = n0i(k-1)/lami(k-1) - end if - else - lami(k-1) = 0._r8 - n0i(k-1) = 0._r8 - end if - - nide(i,k) = ni(i,k-1) - difn(i,k-1) = -du(i,k-1)*nide(i,k) - - niadj(i,k-1)= (ni(i,k-1)- niorg)*mu(i,k-1)/dz(i,k) - - if (niadj(i,k-1) .lt. 0._r8) then - total = nuclin(i,k-1)-fhtimn(i,k-1)-fhtctn(i,k-1)-fhmln(i,k-1)+ hmpin (i,k-1) - if (total .ne. 0._r8) then - nuclin(i,k-1) = nuclin(i,k-1) + nuclin(i,k-1)*niadj(i,k-1)/total - fhtimn(i,k-1) = fhtimn(i,k-1) + fhtimn(i,k-1)*niadj(i,k-1)/total - fhtctn(i,k-1) = fhtctn(i,k-1) + fhtctn(i,k-1)*niadj(i,k-1)/total - fhmln (i,k-1) = fhmln (i,k-1) + fhmln (i,k-1)*niadj(i,k-1)/total - hmpin (i,k-1) = hmpin (i,k-1) + hmpin (i,k-1)*niadj(i,k-1)/total - else - total = 5._r8 - nuclin(i,k-1) = nuclin(i,k-1) + niadj(i,k-1)/total - fhtimn(i,k-1) = fhtimn(i,k-1) + niadj(i,k-1)/total - fhtctn(i,k-1) = fhtctn(i,k-1) + niadj(i,k-1)/total - fhmln (i,k-1) = fhmln (i,k-1) + niadj(i,k-1)/total - hmpin (i,k-1) = hmpin (i,k-1) + niadj(i,k-1)/total - end if - else if (niadj(i,k-1) .gt. 0._r8) then - total = autoin(i,k-1)+accsin(i,k-1) - if (total .ne. 0._r8) then - autoin(i,k-1) = autoin(i,k-1) + autoin(i,k-1)*niadj(i,k-1)/total - accsin(i,k-1) = accsin(i,k-1) + accsin(i,k-1)*niadj(i,k-1)/total - else - total = 2._r8 - autoin(i,k-1) = autoin(i,k-1) + niadj(i,k-1)/total - accsin(i,k-1) = accsin(i,k-1) + niadj(i,k-1)/total - end if - end if - - !................................................................................ - !cloud water - ncorg = nc(i,k-1) - if (qc(i,k-1).ge.qsmall) then - - ! add upper limit to in-cloud number concentration to prevent numerical error - nc(i,k-1)=min(nc(i,k-1),qc(i,k-1)*1.e20_r8) - ! and make sure it's non-negative - ! nc(i,k-1) = max(nc(i,k-1), 0._r8) - if (nc(i,k-1).lt. 0._r8) write(iulog,*) "nc(i,k-1)=",nc(i,k-1) - - ! get pgam from fit to observations of martin et al. 1994 - - pgam(i,k-1)=0.0005714_r8*(nc(i,k-1)/1.e6_r8/rho(i,k-1))+0.2714_r8 - pgam(i,k-1)=1._r8/(pgam(i,k-1)**2)-1._r8 - pgam(i,k-1)=max(pgam(i,k-1),2._r8) - pgam(i,k-1)=min(pgam(i,k-1),15._r8) - ! calculate lamc - - lamc(i,k-1) = (pi/6._r8*rhow*nc(i,k-1)*gamma(pgam(i,k-1)+4._r8)/ & - (qc(i,k-1)*gamma(pgam(i,k-1)+1._r8)))**(1._r8/3._r8) - - ! lammin, 50 micron diameter max mean size - lammin = (pgam(i,k-1)+1._r8)/40.e-6_r8 - lammax = (pgam(i,k-1)+1._r8)/1.e-6_r8 - - if (lamc(i,k-1).lt.lammin) then - lamc(i,k-1) = lammin - nc(i,k-1) = 6._r8*lamc(i,k-1)**3*qc(i,k-1)* & - gamma(pgam(i,k-1)+1._r8)/ & - (pi*rhow*gamma(pgam(i,k-1)+4._r8)) - else if (lamc(i,k-1).gt.lammax) then - lamc(i,k-1) = lammax - nc(i,k-1) = 6._r8*lamc(i,k-1)**3*qc(i,k-1)* & - gamma(pgam(i,k-1)+1._r8)/ & - (pi*rhow*gamma(pgam(i,k-1)+4._r8)) - end if - - ! parameter to calculate droplet freezing - - cdist1(k-1) = nc(i,k-1)/gamma(pgam(i,k-1)+1._r8) - else - lamc(i,k-1) = 0._r8 - cdist1(k-1) = 0._r8 - end if - - ncde(i,k) = nc(i,k-1) - dlfn(i,k-1) = -du(i,k-1)*ncde(i,k) - - ncadj(i,k-1) = (nc(i,k-1)- ncorg)*mu(i,k-1)/dz(i,k) - if (ncadj(i,k-1) .lt. 0._r8) then - activn(i,k-1) = activn(i,k-1) + ncadj(i,k-1) - else if (ncadj(i,k-1) .gt. 0._r8) then - total = autoln(i,k-1)+accrln(i,k-1)+bergnn(i,k-1)+accsln(i,k-1) - if (total .ne. 0._r8) then - autoln(i,k-1) = autoln(i,k-1) + autoln(i,k-1)*ncadj(i,k-1)/total - accrln(i,k-1) = accrln(i,k-1) + accrln(i,k-1)*ncadj(i,k-1)/total - bergnn(i,k-1) = bergnn(i,k-1) + bergnn(i,k-1)*ncadj(i,k-1)/total - accsln(i,k-1) = accsln(i,k-1) + accsln(i,k-1)*ncadj(i,k-1)/total - else - total = 4._r8 - autoln(i,k-1) = autoln(i,k-1) + ncadj(i,k-1)/total - accrln(i,k-1) = accrln(i,k-1) + ncadj(i,k-1)/total - bergnn(i,k-1) = bergnn(i,k-1) + ncadj(i,k-1)/total - accsln(i,k-1) = accsln(i,k-1) + ncadj(i,k-1)/total - end if - end if - - trspcm(i,k-1) = (mu(i,k)*qc(i,k) - mu(i,k-1)*qc(i,k-1))/dz(i,k) - trspcn(i,k-1) = (mu(i,k)*nc(i,k) - mu(i,k-1)*nc(i,k-1))/dz(i,k) - trspim(i,k-1) = (mu(i,k)*qi(i,k) - mu(i,k-1)*qi(i,k-1))/dz(i,k) - trspin(i,k-1) = (mu(i,k)*ni(i,k) - mu(i,k-1)*ni(i,k-1))/dz(i,k) - - if (k-1 .eq. jt(i)+1) then - trspcm(i,k-2) = mu(i,k-1)*qc(i,k-1)/dz(i,k-1) - trspcn(i,k-2) = mu(i,k-1)*nc(i,k-1)/dz(i,k-1) - trspim(i,k-2) = mu(i,k-1)*qi(i,k-1)/dz(i,k-1) - trspin(i,k-2) = mu(i,k-1)*ni(i,k-1)/dz(i,k-1) - qcde(i,k-1) = qc(i,k-1) - ncde(i,k-1) = nc(i,k-1) - qide(i,k-1) = qi(i,k-1) - nide(i,k-1) = ni(i,k-1) - dlfm (i,k-2) = -du(i,k-2)*qcde(i,k-1) - dlfn (i,k-2) = -du(i,k-2)*ncde(i,k-1) - difm (i,k-2) = -du(i,k-2)*qide(i,k-1) - difn (i,k-2) = -du(i,k-2)*nide(i,k-1) - end if - - - !....................................................................... - ! get size distribution parameters for precip - !...................................................................... - ! rain - if (qr(i,k-1).ge.qsmall) then - - lamr(k-1) = (pi*rhow*nr(i,k-1)/qr(i,k-1))**(1._r8/3._r8) - n0r(k-1) = nr(i,k-1)*lamr(k-1) - - ! check for slope - lammax = 1._r8/150.e-6_r8 - lammin = 1._r8/3000.e-6_r8 - ! adjust vars - if (lamr(k-1).lt.lammin) then - lamr(k-1) = lammin - n0r(k-1) = lamr(k-1)**4*qr(i,k-1)/(pi*rhow) - nr(i,k-1) = n0r(k-1)/lamr(k-1) - else if (lamr(k-1).gt.lammax) then - lamr(k-1) = lammax - n0r(k-1) = lamr(k-1)**4*qr(i,k-1)/(pi*rhow) - nr(i,k-1) = n0r(k-1)/lamr(k-1) - end if - - unr(k-1) = min(arn(i,k-1)*gamma(1._r8+br)/lamr(k-1)**br,10._r8) - umr(k-1) = min(arn(i,k-1)*gamma(4._r8+br)/(6._r8*lamr(k-1)**br),10._r8) - else - lamr(k-1) = 0._r8 - n0r(k-1) = 0._r8 - umr(k-1) = 0._r8 - unr(k-1) = 0._r8 - end if - - !...................................................................... - ! snow - if (qni(i,k-1).ge.qsmall) then - lams(k-1) = (gamma(1._r8+ds)*cs*ns(i,k-1)/ & - qni(i,k-1))**(1._r8/ds) - n0s(k-1) = ns(i,k-1)*lams(k-1) - - ! check for slope - lammax = 1._r8/10.e-6_r8 - lammin = 1._r8/2000.e-6_r8 - - ! adjust vars - if (lams(k-1).lt.lammin) then - lams(k-1) = lammin - n0s(k-1) = lams(k-1)**(ds+1._r8)*qni(i,k-1)/(cs*gamma(1._r8+ds)) - ns(i,k-1) = n0s(k-1)/lams(k-1) - else if (lams(k-1).gt.lammax) then - lams(k-1) = lammax - n0s(k-1) = lams(k-1)**(ds+1._r8)*qni(i,k-1)/(cs*gamma(1._r8+ds)) - ns(i,k-1) = n0s(k-1)/lams(k-1) - end if - ums(k-1) = min(asn(i,k-1)*gamma(4._r8+bs)/(6._r8*lams(k-1)**bs),3.6_r8) - uns(k-1) = min(asn(i,k-1)*gamma(1._r8+bs)/lams(k-1)**bs,3.6_r8) - else - lams(k-1) = 0._r8 - n0s(k-1) = 0._r8 - ums(k-1) = 0._r8 - uns(k-1) = 0._r8 - end if - - rprd(i,k-1)= (qnitend(i,k) + qrtend(i,k))*arcf(i,k) - sprd(i,k-1)= qnitend(i,k) *arcf(i,k) -fhmrm(i,k-1) - - end if ! k