diff --git a/Makefile.am b/Makefile.am index b51234f8..99e76ee5 100644 --- a/Makefile.am +++ b/Makefile.am @@ -134,6 +134,8 @@ libatmos_phys_la_SOURCES = ${top_srcdir}/atmos_shared/atmos_nudge/atmos_nudge.F9 ${top_srcdir}/atmos_param/microphysics/morrison_gettelman_microp.F90 \ ${top_srcdir}/atmos_param/microphysics/gamma_mg.F90 \ ${top_srcdir}/atmos_param/microphysics/micro_mg.F90 \ + ${top_srcdir}/atmos_param/microphysics/micro_mg2.F90 \ + ${top_srcdir}/atmos_param/microphysics/micro_mg2_utils.F90 \ ${top_srcdir}/atmos_param/microphysics/rotstayn_klein_mp.F90 \ ${top_srcdir}/atmos_param/microphysics/ls_cloud_microphysics.F90 \ ${top_srcdir}/atmos_param/microphysics/simple_pdf.F90 \ @@ -783,6 +785,13 @@ ${top_builddir}/atmos_param/microphysics/micro_mg.lo: ${top_srcdir}/atmos_param/ ${top_srcdir}/atmos_param/lscloud_driver/lscloud_types.lo \ ${top_srcdir}/atmos_param/microphysics/simple_pdf.lo \ ${top_srcdir}/atmos_param/physics_radiation_exch/physics_radiation_exch.lo +${top_builddir}/atmos_param/microphysics/micro_mg2.lo: ${top_srcdir}/atmos_param/microphysics/micro_mg2.F90 \ + ${top_srcdir}/atmos_param/microphysics/micro_mg2_utils.lo \ + ${top_srcdir}/atmos_param/microphysics/gamma_mg.lo \ + ${top_srcdir}/atmos_param/lscloud_driver/lscloud_types.lo \ + ${top_srcdir}/atmos_param/physics_radiation_exch/physics_radiation_exch.lo +${top_builddir}/atmos_param/microphysics/micro_mg2_utils.lo: ${top_srcdir}/atmos_param/microphysics/micro_mg2_utils.F90 \ + ${top_srcdir}/atmos_param/microphysics/gamma_mg.lo ${top_builddir}/atmos_param/microphysics/rotstayn_klein_mp.lo: ${top_srcdir}/atmos_param/microphysics/rotstayn_klein_mp.F90 \ ${top_srcdir}/atmos_param/cloud_generator/cloud_generator.lo \ ${top_srcdir}/atmos_shared/tracer_driver/aer_ccn_act/aer_in_act.lo \ @@ -801,7 +810,8 @@ ${top_builddir}/atmos_param/microphysics/ls_cloud_microphysics.lo: ${top_srcdir} ${top_srcdir}/atmos_param/microphysics/rotstayn_klein_mp.lo \ ${top_srcdir}/atmos_param/microphysics/morrison_gettelman_microp.lo \ ${top_srcdir}/atmos_param/microphysics/cldwat2m_micro.lo \ - ${top_srcdir}/atmos_param/microphysics/micro_mg.lo + ${top_srcdir}/atmos_param/microphysics/micro_mg.lo \ + ${top_srcdir}/atmos_param/microphysics/micro_mg2.lo ${top_builddir}/atmos_param/microphysics/simple_pdf.lo: ${top_srcdir}/atmos_param/microphysics/simple_pdf.F90 \ ${top_srcdir}/atmos_param/cloud_generator/betaDistribution.lo \ ${top_srcdir}/atmos_param/lscloud_driver/lscloud_types.lo @@ -1661,6 +1671,8 @@ morrison_gettelman_microp_mod.mod: ${top_srcdir}/atmos_param/microphysics/morris gamma_mg_mod.mod: ${top_srcdir}/atmos_param/microphysics/gamma_mg.lo micro_mg_mod.mod: ${top_srcdir}/atmos_param/microphysics/micro_mg.lo micro_mg1_5.mod: ${top_srcdir}/atmos_param/microphysics/micro_mg.lo +micro_mg2_mod.mod: ${top_srcdir}/atmos_param/microphysics/micro_mg2.lo +micro_mg2_utils.mod: ${top_srcdir}/atmos_param/microphysics/micro_mg2_utils.lo rotstayn_klein_mp_mod.mod: ${top_srcdir}/atmos_param/microphysics/rotstayn_klein_mp.lo ls_cloud_microphysics_mod.mod: ${top_srcdir}/atmos_param/microphysics/ls_cloud_microphysics.lo simple_pdf_mod.mod: ${top_srcdir}/atmos_param/microphysics/simple_pdf.lo @@ -1973,6 +1985,8 @@ include_HEADERS = atmos_nudge_mod.mod \ gamma_mg_mod.mod \ micro_mg_mod.mod \ micro_mg1_5.mod \ + micro_mg2_mod.mod \ + micro_mg2_utils.mod \ rotstayn_klein_mp_mod.mod \ ls_cloud_microphysics_mod.mod \ simple_pdf_mod.mod \ diff --git a/atmos_param/aerosol_cloud/aerosol_cloud.F90 b/atmos_param/aerosol_cloud/aerosol_cloud.F90 index 785eb09e..ed3ae2e9 100644 --- a/atmos_param/aerosol_cloud/aerosol_cloud.F90 +++ b/atmos_param/aerosol_cloud/aerosol_cloud.F90 @@ -27,7 +27,8 @@ MODULE aerosol_cloud_mod USE aer_ccn_act_mod, ONLY : aer_ccn_act_wpdf_m, & aer_ccn_act_init, aer_ccn_act_end USE ice_nucl_mod, ONLY : ice_nucl_wpdf, ice_nucl_wpdf_init, & - ice_nucl_wpdf_end + ice_nucl_wpdf_end, ice_nucl_wpdf_Fan + USE lscloud_types_mod, ONLY : lscloud_types_init, & diag_id_type, diag_pt_type, & atmos_state_type, lscloud_nml_type,& @@ -90,13 +91,19 @@ MODULE aerosol_cloud_mod integer :: var_limit_opt = 1 integer :: up_strat_opt = 1 -namelist / aerosol_cloud_nml / rh_act_opt, sea_salt_scale_onl, & - reproduce_rk, var_limit_ice, & - var_limit, var_limit_opt, up_strat_opt, & - cf_thresh_nucl, treat_nitrate_as_sulfate - +logical :: use_Fan2019_ice_nucl = .false. +logical :: do_sum_homo_het_Fan = .true. ! h1g, 2020-06-01 +logical :: include_all_dust_bins = .false. ! h1g, 2020-06-01 +logical :: include_Ni_bc = .false. ! h1g, 2020-07-03 +logical :: include_Ni_sulf = .false. ! h1g, 2020-07-03 +namelist / aerosol_cloud_nml / rh_act_opt, sea_salt_scale_onl, & + reproduce_rk, var_limit_ice, & + var_limit, var_limit_opt, up_strat_opt, & + cf_thresh_nucl, treat_nitrate_as_sulfate, & + use_Fan2019_ice_nucl, do_sum_homo_het_Fan,& ! h1g, 2020-06-01 + include_all_dust_bins, include_Ni_bc, include_Ni_sulf ! h1g, 2020-07-03 !------------------------------------------------------------------------- real, parameter :: d622 = rdgas / rvgas @@ -123,7 +130,7 @@ MODULE aerosol_cloud_mod real :: sea_salt_scale real :: om_to_oc logical :: do_pdf_clouds -logical :: do_mg_microphys, do_mg_ncar_microphys, do_ncar_microphys +logical :: do_mg_microphys, do_mg_ncar_microphys, do_ncar_microphys, do_ncar_MG2 logical :: total_activation logical :: debug @@ -166,6 +173,9 @@ subroutine aerosol_cloud_init (Constants_lsc, Nml_lsc, Nml_mp, Exch_ctrl) do_mg_microphys = Constants_lsc%do_mg_microphys do_mg_ncar_microphys = Constants_lsc%do_mg_ncar_microphys do_ncar_microphys = Constants_lsc%do_ncar_microphys + + do_ncar_MG2 =Constants_lsc%do_ncar_MG2 + total_activation = Constants_lsc%total_activation !------------------------------------------------------------------------- @@ -330,6 +340,8 @@ subroutine determine_activated_aerosol ( & eslt, esit, qvsl, qvsi, qs_d, qvt INTEGER :: i, j, k + real :: crystal_tmp, ni_dust_tmp + !------------------------------------------------------------------------- ! do the following calculations if droplet number is being predicted: @@ -372,6 +384,7 @@ subroutine determine_activated_aerosol ( & ! downward, the rotstayn-klein microphysics is active, and pdf_clouds ! are not activated; in such a case, no particles are activated. !------------------------------------------------------------------------- + call mpp_clock_begin (aero_loop2) if (var_limit_opt == 1) then ! cjg do k = 1,kdim @@ -381,6 +394,7 @@ subroutine determine_activated_aerosol ( & (do_mg_microphys) .or. & (do_ncar_microphys) .or. & (do_mg_ncar_microphys) .or. & + ( do_ncar_MG2 ) .or. & ! cjg: total activation for RK (total_activation) .or. & (up_strat(i,j,k) >= 0.0) ) then @@ -434,6 +448,34 @@ subroutine determine_activated_aerosol ( & !------------------------------------------------------------------------- call mpp_clock_begin (aero_loop3) if (do_ice_num) then + +!---> h1g, 2020-06-01 + if ( .not. do_ice_nucl_wpdf ) then + do k = 1,kdim + do j = 1,jdim + do i = 1,idim + wp2i(i,j,k) = 0.0 + if (use_Fan2019_ice_nucl) then +!------------------------------------------------------------------------- +! call ice_nucl_wpdf to obtain number of activated ice crystals. +!------------------------------------------------------------------------- + call ice_nucl_wpdf_Fan ( & + Input_mp%tin(i,j,k), & + Input_mp%pfull(i,j,k), & + up_strat(i,j,k), wp2i(i,j,k), & + Particles%concen_dust_sub(i,j,k), & + Particles%crystal1(i,j,k), & !Particles%crystal1(i,j,k): homogeneous nucleated ice + Ni_dust(i,j,k) ) + if ( do_sum_homo_het_Fan ) & + Particles%crystal1(i,j,k) = Particles%crystal1(i,j,k) + Ni_dust(i,j,k) + endif + enddo + enddo + enddo + endif +!<--- h1g, 2020-06-01 + + if (do_ice_nucl_wpdf) THEN do k = 1,kdim do j = 1,jdim @@ -453,64 +495,140 @@ subroutine determine_activated_aerosol ( & wp2i(i,j,k) = wp2(i,j,k) END IF + + if (use_Fan2019_ice_nucl) then +!------------------------------------------------------------------------- +! call ice_nucl_wpdf to obtain number of activated ice crystals. +!------------------------------------------------------------------------- + call ice_nucl_wpdf_Fan ( & + Input_mp%tin(i,j,k), & + Input_mp%pfull(i,j,k), & + up_strat(i,j,k), wp2i(i,j,k), & + Particles%concen_dust_sub(i,j,k), & + Particles%crystal1(i,j,k), &!Particles%crystal1(i,j,k): homogeneous nucleated ice + Ni_dust(i,j,k) ) + if ( do_sum_homo_het_Fan ) & + Particles%crystal1(i,j,k) = Particles%crystal1(i,j,k) + Ni_dust(i,j,k) + !------------------------------------------------------------------------ ! define the saturation specific humidities over liquid and ice. !------------------------------------------------------------------------ - eslt(i,j,k) = polysvp_l(Input_mp%tin(i,j,k)) - qs_d(i,j,k) = Input_mp%pfull(i,j,k) - d378*eslt(i,j,k) - qs_d(i,j,k) = max(qs_d(i,j,k),eslt(i,j,k)) - qvsl(i,j,k) = 0.622 *eslt(i,j,k)/qs_d(i,j,k) + eslt(i,j,k) = polysvp_l(Input_mp%tin(i,j,k)) + qs_d(i,j,k) = Input_mp%pfull(i,j,k) - d378*eslt(i,j,k) + qs_d(i,j,k) = max(qs_d(i,j,k),eslt(i,j,k)) + qvsl(i,j,k) = 0.622 *eslt(i,j,k)/qs_d(i,j,k) - esit(i,j,k) = polysvp_i(Input_mp%tin(i,j,k)) - qs_d(i,j,k) = Input_mp%pfull(i,j,k) - d378*esit(i,j,k) - qs_d(i,j,k) = max(qs_d(i,j,k),esit(i,j,k)) - qvsi(i,j,k) = 0.622 *esit(i,j,k)/qs_d(i,j,k) + esit(i,j,k) = polysvp_i(Input_mp%tin(i,j,k)) + qs_d(i,j,k) = Input_mp%pfull(i,j,k) - d378*esit(i,j,k) + qs_d(i,j,k) = max(qs_d(i,j,k),esit(i,j,k)) + qvsi(i,j,k) = 0.622 *esit(i,j,k)/qs_d(i,j,k) !------------------------------------------------------------------------ ! define the relative humidities wrt ice and liquid to be used in the ! calculation of ice nuclei activation. it may vary based on the nml ! variable rh_act_opt. !------------------------------------------------------------------------ - IF (rh_act_opt .EQ. 1) THEN - qvt(i,j,k) = Input_mp%qin(i,j,k) - cf(i,j,k) = 0. - ELSE - cf(i,j,k) = qa_upd(i,j,k) + & + IF (rh_act_opt .EQ. 1) THEN + qvt(i,j,k) = Input_mp%qin(i,j,k) + cf(i,j,k) = 0. + ELSE + cf(i,j,k) = qa_upd(i,j,k) + & C2ls_mp%convective_humidity_area(i,j,k) - IF (cf(i,j,k) .LT. cf_thresh_nucl) THEN - qvt(i,j,k) = (Input_mp%qin(i,j,k) - & + IF (cf(i,j,k) .LT. cf_thresh_nucl) THEN + qvt(i,j,k) = (Input_mp%qin(i,j,k) - & cf(i,j,k)*Atmos_State%qs(i,j,k))/ & (1. - cf(i,j,k)) + ELSE + qvt(i,j,k) = Input_mp%qin(i,j,k) + ENDIF + END IF + + if (qvt(i,j,k) .LE. 0.0) then + qvt(i,j,k) = MAX(Input_mp%qin(i,j,k), qmin) + endif + u_i(i,j,k) = qvt(i,j,k)/qvsi(i,j,k) + u_l(i,j,k) = qvt(i,j,k)/qvsl(i,j,k) + +!------------------------------------------------------------------------- +! call ice_nucl_wpdf to obtain number of activated ice crystals. +!------------------------------------------------------------------------- + call ice_nucl_wpdf ( & + Input_mp%tin(i,j,k), u_i(i,j,k), u_l(i,j,k),& + up_strat(i,j,k), wp2i(i,j,k), & + Input_mp%zfull(i,j,k), & + Particles%totalmass1(i,j,k,:), & + Particles%imass1(i,j,k,:), n_totmass, n_imass, & + crystal_tmp, & + Particles%drop1(i,j,k), Particles%hom(i,j,k), & + Atmos_state%rh_crit(i,j,k), & + Atmos_state%rh_crit_min(i,j,k), ni_sulf(i,j,k), & + ni_dust_tmp, ni_bc(i,j,k)) + + + if ( include_Ni_bc ) & + Particles%crystal1(i,j,k) = Particles%crystal1(i,j,k) + ni_bc(i,j,k) + if ( include_Ni_sulf ) & + Particles%crystal1(i,j,k) = Particles%crystal1(i,j,k) + ni_sulf(i,j,k) + + else +!------------------------------------------------------------------------ +! define the saturation specific humidities over liquid and ice. +!------------------------------------------------------------------------ + eslt(i,j,k) = polysvp_l(Input_mp%tin(i,j,k)) + qs_d(i,j,k) = Input_mp%pfull(i,j,k) - d378*eslt(i,j,k) + qs_d(i,j,k) = max(qs_d(i,j,k),eslt(i,j,k)) + qvsl(i,j,k) = 0.622 *eslt(i,j,k)/qs_d(i,j,k) + + esit(i,j,k) = polysvp_i(Input_mp%tin(i,j,k)) + qs_d(i,j,k) = Input_mp%pfull(i,j,k) - d378*esit(i,j,k) + qs_d(i,j,k) = max(qs_d(i,j,k),esit(i,j,k)) + qvsi(i,j,k) = 0.622 *esit(i,j,k)/qs_d(i,j,k) + +!------------------------------------------------------------------------ +! define the relative humidities wrt ice and liquid to be used in the +! calculation of ice nuclei activation. it may vary based on the nml +! variable rh_act_opt. +!------------------------------------------------------------------------ + IF (rh_act_opt .EQ. 1) THEN + qvt(i,j,k) = Input_mp%qin(i,j,k) + cf(i,j,k) = 0. ELSE - qvt(i,j,k) = Input_mp%qin(i,j,k) - ENDIF - END IF + cf(i,j,k) = qa_upd(i,j,k) + & + C2ls_mp%convective_humidity_area(i,j,k) + IF (cf(i,j,k) .LT. cf_thresh_nucl) THEN + qvt(i,j,k) = (Input_mp%qin(i,j,k) - & + cf(i,j,k)*Atmos_State%qs(i,j,k))/ & + (1. - cf(i,j,k)) + ELSE + qvt(i,j,k) = Input_mp%qin(i,j,k) + ENDIF + END IF - if (qvt(i,j,k) .LE. 0.0) then - qvt(i,j,k) = MAX(Input_mp%qin(i,j,k), qmin) - endif - u_i(i,j,k) = qvt(i,j,k)/qvsi(i,j,k) - u_l(i,j,k) = qvt(i,j,k)/qvsl(i,j,k) + if (qvt(i,j,k) .LE. 0.0) then + qvt(i,j,k) = MAX(Input_mp%qin(i,j,k), qmin) + endif + u_i(i,j,k) = qvt(i,j,k)/qvsi(i,j,k) + u_l(i,j,k) = qvt(i,j,k)/qvsl(i,j,k) !-------------------------------------------------------------------------- ! if debugging is active and the relative humidity exceeds 200%, output ! relevant variables. !-------------------------------------------------------------------------- - if (debug .and. Input_mp%tin(i,j,k) .lt. 260. .and. & + if (debug .and. Input_mp%tin(i,j,k) .lt. 260. .and. & u_i(i,j,k) .gt. 200. ) then - call aerosol_cloud_debug1 ( & - i, j, k, u_i(i,j,k), Atmos_state%qs(i,j,k), & - qvsi(i,j,k), qvt(i,j,k), Input_mp%qin(i,j,k), & - cf(i,j,k), & - C2ls_mp%convective_humidity_area(i,j,k), & - qa_upd(i,j,k), & - C2ls_mp%convective_humidity_ratio(i,j,k) ) - endif + call aerosol_cloud_debug1 ( & + i, j, k, u_i(i,j,k), Atmos_state%qs(i,j,k), & + qvsi(i,j,k), qvt(i,j,k), Input_mp%qin(i,j,k), & + cf(i,j,k), & + C2ls_mp%convective_humidity_area(i,j,k), & + qa_upd(i,j,k), & + C2ls_mp%convective_humidity_ratio(i,j,k) ) + endif !------------------------------------------------------------------------- ! call ice_nucl_wpdf to obtain number of activated ice crystals. !------------------------------------------------------------------------- - call ice_nucl_wpdf ( & + call ice_nucl_wpdf ( & Input_mp%tin(i,j,k), u_i(i,j,k), u_l(i,j,k),& up_strat(i,j,k), wp2i(i,j,k), & Input_mp%zfull(i,j,k), & @@ -521,14 +639,16 @@ subroutine determine_activated_aerosol ( & Atmos_state%rh_crit(i,j,k), & Atmos_state%rh_crit_min(i,j,k), ni_sulf(i,j,k), & ni_dust(i,j,k), ni_bc(i,j,k)) - else - ni_sulf(i,j,k) = 0. - ni_dust(i,j,k) = 0. - ni_bc (i,j,k) = 0. - cf(i,j,k) = missing_value - u_i(i,j,k) = missing_value - u_l(i,j,k) = missing_value - endif + endif !use_Fan2019_ice_nucl + + else + ni_sulf(i,j,k) = 0. + ni_dust(i,j,k) = 0. + ni_bc (i,j,k) = 0. + cf(i,j,k) = missing_value + u_i(i,j,k) = missing_value + u_l(i,j,k) = missing_value + endif ! Input_mp%tin(i,j,k) .LT. tfreeze - 5. !------------------------------------------------------------------------- ! define the critical relative humidity that was used for ice nuclei @@ -562,6 +682,7 @@ subroutine determine_activated_aerosol ( & end do end do end do + END IF ! do_ice_nucl_wpdf !------------------------------------------------------------------------- ! define various desired diagnostics. @@ -617,7 +738,6 @@ subroutine determine_activated_aerosol ( & if ( diag_id%rhlin > 0 ) diag_4d(:,:,:,diag_pt%rhlin) = u_l - END IF ! do_ice_nucl_wpdf END IF ! do_ice_num if(diag_id%potential_droplets > 0) & @@ -879,6 +999,13 @@ subroutine aerosol_effects (idim,jdim,kdim,n_diag_4d, pthickness, & do i=1,idim imass1(i,j,k,11) = Aerosol%aerosol(i,j,k,na)/ & pthickness(i,j,k) +!--> h1g, 2020-06-01 + if ( do_dust_berg .and. include_all_dust_bins ) then + concen_dust_sub(i,j,k) = concen_dust_sub(i,j,k) + & + Aerosol%aerosol(i,j,k,na) + endif +!<-- h1g, 2020-06-01 + end do end do end do @@ -889,6 +1016,14 @@ subroutine aerosol_effects (idim,jdim,kdim,n_diag_4d, pthickness, & do i=1,idim imass1(i,j,k,12) = Aerosol%aerosol(i,j,k,na)/ & pthickness(i,j,k) + +!--> h1g, 2020-06-01 + if ( do_dust_berg .and. include_all_dust_bins ) then + concen_dust_sub(i,j,k) = concen_dust_sub(i,j,k) + & + Aerosol%aerosol(i,j,k,na) + endif +!<-- h1g, 2020-06-01 + end do end do end do @@ -1027,12 +1162,8 @@ subroutine aerosol_effects (idim,jdim,kdim,n_diag_4d, pthickness, & endif ! (do_liq_num) !---------------------------------------------------------------------- - - end subroutine aerosol_effects - !######################################################################### - END MODULE aerosol_cloud_mod diff --git a/atmos_param/lscloud_driver/lscloud_driver.F90 b/atmos_param/lscloud_driver/lscloud_driver.F90 index 46ca8f23..2e411188 100644 --- a/atmos_param/lscloud_driver/lscloud_driver.F90 +++ b/atmos_param/lscloud_driver/lscloud_driver.F90 @@ -210,7 +210,7 @@ module lscloud_driver_mod integer :: kord = 7 logical :: pdf_org = .true. logical :: use_cf_metadata = .false. - +logical :: do_liq_num_fill = .true. namelist / lscloud_driver_nml / do_legacy_strat_cloud, Dmin, cfact, & microphys_scheme, macrophys_scheme, & @@ -219,7 +219,8 @@ module lscloud_driver_mod super_ice_opt, do_ice_nucl_wpdf, & do_pdf_clouds, betaP, qthalfwidth, & nsublevels, kmap, kord, pdf_org, & - use_cf_metadata + use_cf_metadata, & + do_liq_num_fill ! h1g, 2020-03-19 @@ -253,8 +254,8 @@ module lscloud_driver_mod id_lsc_precip, id_lsc_freq, & id_lscale_rain3d, id_lscale_snow3d, id_lscale_precip3d -integer :: id_qvout, id_qaout, id_qlout, id_qiout -integer :: id_qnout, id_qniout +integer :: id_qvout, id_qaout, id_qlout, id_qiout, id_qrout, id_qsout, id_qgout +integer :: id_qnout, id_qniout, id_qnrout, id_qnsout integer :: id_f_snow_berg, id_f_snow_berg_cond, id_f_snow_berg_wtd integer, dimension(:), allocatable :: id_wet_deposition @@ -286,7 +287,7 @@ module lscloud_driver_mod real :: dtcloud, inv_dtcloud logical :: do_predicted_ice_number -integer :: nsphum, nql, nqi, nqa, nqn, nqni, nqr, nqs, nqg +integer :: nsphum, nql, nqi, nqa, nqn, nqni, nqr, nqs, nqg, nqnr, nqns integer :: nso2, nso4 integer :: num_prog_tracers logical :: debug @@ -367,7 +368,9 @@ subroutine lscloud_driver_init (domain, id, jd, kd, axes, Time, & nqni = Physics_control%nqni nqr = Physics_control%nqr nqs = Physics_control%nqs - nqg = Physics_control%nqg + nqg = Physics_control%nqg + nqnr = Physics_control%nqnr + nqns = Physics_control%nqns num_prog_tracers = Physics_control%num_prog_tracers !------------------------------------------------------------------------- @@ -614,6 +617,7 @@ subroutine lscloud_driver_init (domain, id, jd, kd, axes, Time, & Constants_lsc%do_mg_microphys = .false. Constants_lsc%do_mg_ncar_microphys = .false. Constants_lsc%do_ncar_microphys = .false. + Constants_lsc%do_ncar_MG2 = .false. do_predicted_ice_number = .false. Constants_lsc%do_lin_cld_microphys = .false. else if (trim(microphys_scheme) == 'morrison_gettelman') then @@ -621,6 +625,7 @@ subroutine lscloud_driver_init (domain, id, jd, kd, axes, Time, & Constants_lsc%do_mg_microphys = .true. Constants_lsc%do_mg_ncar_microphys = .false. Constants_lsc%do_ncar_microphys = .false. + Constants_lsc%do_ncar_MG2 = .false. do_predicted_ice_number = .true. Constants_lsc%do_lin_cld_microphys = .false. else if (trim(microphys_scheme) == 'mg_ncar') then @@ -628,6 +633,7 @@ subroutine lscloud_driver_init (domain, id, jd, kd, axes, Time, & Constants_lsc%do_mg_microphys = .false. Constants_lsc%do_mg_ncar_microphys = .true. Constants_lsc%do_ncar_microphys = .false. + Constants_lsc%do_ncar_MG2 = .false. do_predicted_ice_number = .true. Constants_lsc%do_lin_cld_microphys = .false. else if (trim(microphys_scheme) == 'ncar') then @@ -635,6 +641,15 @@ subroutine lscloud_driver_init (domain, id, jd, kd, axes, Time, & Constants_lsc%do_mg_microphys = .false. Constants_lsc%do_mg_ncar_microphys = .false. Constants_lsc%do_ncar_microphys = .true. + Constants_lsc%do_ncar_MG2 = .false. + do_predicted_ice_number = .true. + Constants_lsc%do_lin_cld_microphys = .false. + else if (trim(microphys_scheme) == 'mg2') then + Constants_lsc%do_rk_microphys = .false. + Constants_lsc%do_mg_microphys = .false. + Constants_lsc%do_mg_ncar_microphys = .false. + Constants_lsc%do_ncar_microphys = .false. + Constants_lsc%do_ncar_MG2 = .true. do_predicted_ice_number = .true. Constants_lsc%do_lin_cld_microphys = .false. else if (trim(microphys_scheme) == 'lin') then @@ -642,6 +657,7 @@ subroutine lscloud_driver_init (domain, id, jd, kd, axes, Time, & Constants_lsc%do_mg_microphys = .false. Constants_lsc%do_mg_ncar_microphys = .false. Constants_lsc%do_ncar_microphys = .false. + Constants_lsc%do_ncar_MG2 = .false. Constants_lsc%do_lin_cld_microphys = .true. ! this version of lin could not be active with prog drop number (and thus ! with predicted ice number) @@ -738,6 +754,7 @@ subroutine lscloud_driver_init (domain, id, jd, kd, axes, Time, & Constants_lsc%do_mg_microphys = .false. Constants_lsc%do_mg_ncar_microphys = .false. Constants_lsc%do_ncar_microphys = .false. + Constants_lsc%do_ncar_MG2 = .false. do_predicted_ice_number = .false. Constants_lsc%do_lin_cld_microphys = .false. Constants_lsc%dqa_activation = .false. @@ -841,7 +858,7 @@ end subroutine lscloud_driver_time_vary !######################################################################### -subroutine lscloud_driver (is, ie, js, je, Time, dt, Input_mp, & +subroutine lscloud_driver (is, ie, js, je, Time, dt, lon, lat, Input_mp, & rdiag, Tend_mp, C2ls_mp, Output_mp, & Removal_mp, Cld_props, Aerosol) @@ -877,6 +894,8 @@ subroutine lscloud_driver (is, ie, js, je, Time, dt, Input_mp, & integer, intent(in) :: is,ie,js,je type(time_type), intent(in) :: Time real, intent(in) :: dt +real, intent(in), dimension(:,:) :: lon, lat + type(mp_input_type), intent(inout) :: Input_mp type(mp_tendency_type), intent(inout) :: Tend_mp type(mp_conv2ls_type), intent(inout) :: C2ls_mp @@ -1028,7 +1047,7 @@ subroutine lscloud_driver (is, ie, js, je, Time, dt, Input_mp, & ! fields. start clock to time this subroutine. !---------------------------------------------------------------------- call mpp_clock_begin (realiz_clock) - call impose_realizability ( & + call impose_realizability ( & Atmos_state, Cloud_state, Tend_mp%qtnd, Tend_mp%ttnd, & Lsdiag_mp%diag_4d, Lsdiag_mp_control%diag_id, & Lsdiag_mp_control%diag_pt) @@ -1132,7 +1151,7 @@ subroutine lscloud_driver (is, ie, js, je, Time, dt, Input_mp, & !--------------------------------------------------------------------- call mpp_clock_begin (ls_microphysics_clock) call ls_cloud_microphysics & - (is, ie, js, je, Time, dt, & + (is, ie, js, je, Time, dt, lon, lat, & Input_mp, Output_mp, C2ls_mp, Tend_mp, Lsdiag_mp, & Lsdiag_mp_control, & Atmos_state, Cloud_state, Particles, Precip_state, & @@ -1578,6 +1597,26 @@ subroutine diag_field_init (axes, Time) 'qlout', axes(1:3), Time, 'ql after strat_cloud', 'kg/kg', & missing_value=missing_value ) + id_qrout = register_diag_field ( mod_name, & + 'qrout', axes(1:3), Time, 'qr after strat_cloud', 'kg/kg', & + missing_value=missing_value ) + + id_qsout = register_diag_field ( mod_name, & + 'qsout', axes(1:3), Time, 'qs after strat_cloud', 'kg/kg', & + missing_value=missing_value ) + + id_qnrout = register_diag_field ( mod_name, & + 'qnrout', axes(1:3), Time, 'qnr after strat_cloud', '#/kg', & + missing_value=missing_value ) + + id_qnsout = register_diag_field ( mod_name, & + 'qnsout', axes(1:3), Time, 'qns after strat_cloud', '#/kg', & + missing_value=missing_value ) + + id_qgout = register_diag_field ( mod_name, & + 'qgout', axes(1:3), Time, 'qg after strat_cloud', 'kg/kg', & + missing_value=missing_value ) + id_qiout = register_diag_field ( mod_name, & 'qiout', axes(1:3), Time, 'qi after strat_cloud', 'kg/kg', & missing_value=missing_value ) @@ -1847,24 +1886,45 @@ subroutine lscloud_alloc ( & allocate (Cloud_state%qa_upd (idim, jdim, kdim) ) allocate (Cloud_state%qn_upd (idim, jdim, kdim) ) allocate (Cloud_state%qni_upd (idim, jdim, kdim) ) + allocate (Cloud_state%qr_upd (idim, jdim, kdim) ) + allocate (Cloud_state%qs_upd (idim, jdim, kdim) ) + allocate (Cloud_state%qnr_upd (idim, jdim, kdim) ) + allocate (Cloud_state%qns_upd (idim, jdim, kdim) ) + allocate (Cloud_state%ql_mean (idim, jdim, kdim) ) allocate (Cloud_state%qi_mean (idim, jdim, kdim) ) allocate (Cloud_state%qa_mean (idim, jdim, kdim) ) allocate (Cloud_state%qn_mean (idim, jdim, kdim) ) allocate (Cloud_state%qni_mean (idim, jdim, kdim) ) + allocate (Cloud_state%qr_mean (idim, jdim, kdim) ) + allocate (Cloud_state%qs_mean (idim, jdim, kdim) ) + allocate (Cloud_state%qnr_mean (idim, jdim, kdim) ) + allocate (Cloud_state%qns_mean (idim, jdim, kdim) ) + allocate (Cloud_state%ql_in (idim, jdim, kdim) ) + allocate (Cloud_state%qr_in (idim, jdim, kdim) ) allocate (Cloud_state%qi_in (idim, jdim, kdim) ) + allocate (Cloud_state%qs_in (idim, jdim, kdim) ) + allocate (Cloud_state%qg_in (idim, jdim, kdim) ) allocate (Cloud_state%qa_in (idim, jdim, kdim) ) allocate (Cloud_state%qn_in (idim, jdim, kdim) ) allocate (Cloud_state%qni_in (idim, jdim, kdim) ) + allocate (Cloud_state%qnr_in (idim, jdim, kdim) ) + allocate (Cloud_state%qns_in (idim, jdim, kdim) ) + allocate (Cloud_state%SL_out (idim, jdim, kdim) ) allocate (Cloud_state%SI_out (idim, jdim, kdim) ) allocate (Cloud_state%SA_out (idim, jdim, kdim) ) allocate (Cloud_state%SN_out (idim, jdim, kdim) ) allocate (Cloud_state%SNi_out (idim, jdim, kdim) ) + allocate (Cloud_state%SR_out (idim, jdim, kdim) ) + allocate (Cloud_state%SS_out (idim, jdim, kdim) ) + allocate (Cloud_state%SNR_out (idim, jdim, kdim) ) + allocate (Cloud_state%SNS_out (idim, jdim, kdim) ) + allocate (Cloud_state%qcvar_clubb (idim, jdim, kdim) ) allocate (Cloud_state%relvarn (idim, jdim, kdim) ) @@ -1876,23 +1936,48 @@ subroutine lscloud_alloc ( & Cloud_state%qa_upd = 0. Cloud_state%qn_upd = 0. Cloud_state%qni_upd = 0. + Cloud_state%qr_upd = 0. + Cloud_state%qs_upd = 0. + Cloud_state%qnr_upd = 0. + Cloud_state%qns_upd = 0. Cloud_state%ql_mean = 0. Cloud_state%qi_mean = 0. Cloud_state%qa_mean = 0. Cloud_state%qn_mean = 0. Cloud_state%qni_mean = 0. + Cloud_state%qr_mean = 0. + Cloud_state%qs_mean = 0. + Cloud_state%qnr_mean = 0. + Cloud_state%qns_mean = 0. + + if (nql == NO_TRACER) then Cloud_state%ql_in = 0. else Cloud_state%ql_in = Input_mp%tracer(:,:,:,nql) endif + if (nqr == NO_TRACER) then + Cloud_state%qr_in = 0. + else + Cloud_state%qr_in = Input_mp%tracer(:,:,:,nqr) + endif if (nqi == NO_TRACER) then Cloud_state%qi_in = 0. else Cloud_state%qi_in = Input_mp%tracer(:,:,:,nqi) endif + if (nqs == NO_TRACER) then + Cloud_state%qs_in = 0. + else + Cloud_state%qs_in = Input_mp%tracer(:,:,:,nqs) + endif + if (nqg == NO_TRACER) then + Cloud_state%qg_in = 0. + else + Cloud_state%qg_in = Input_mp%tracer(:,:,:,nqg) + endif if (nqa == NO_TRACER) then Cloud_state%qa_in = 0. else @@ -1903,21 +1988,34 @@ subroutine lscloud_alloc ( & else Cloud_state%qn_in = Input_mp%tracer(:,:,:,nqn) end if - if (nqni == NO_TRACER) then Cloud_state%qni_in = 0. else Cloud_state%qni_in = Input_mp%tracer(:,:,:,nqni) end if + if (nqnr == NO_TRACER) then + Cloud_state%qnr_in = 0. + else + Cloud_state%qnr_in = Input_mp%tracer(:,:,:,nqnr) + endif + if (nqns == NO_TRACER) then + Cloud_state%qns_in = 0. + else + Cloud_state%qns_in = Input_mp%tracer(:,:,:,nqns) + endif Cloud_state%SL_out = 0. Cloud_state%SI_out = 0. Cloud_state%SA_out = 0. Cloud_state%SN_out = 0. Cloud_state%SNi_out = 0. + Cloud_state%SR_out = 0. + Cloud_state%SS_out = 0. + Cloud_state%SNR_out = 0. + Cloud_state%SNS_out = 0. Cloud_state%qcvar_clubb = 0. - Cloud_state%relvarn = 0. + Cloud_state%relvarn = qcvar Cloud_state%qa_upd_0 = 0. Cloud_state%SA_0 = 0. @@ -1963,7 +2061,8 @@ subroutine impose_realizability ( & ! local variables: logical, dimension(size(ST_out,1), size(ST_out,2), & - size(ST_out,3)) :: ql_too_small, qi_too_small + size(ST_out,3)) :: ql_too_small, qi_too_small, qr_too_small, & + qs_too_small, qg_too_small integer :: idim,jdim,kdim integer :: i,j,k @@ -2042,6 +2141,14 @@ subroutine impose_realizability ( & qi_too_small = (Cloud_state%qi_in .le. qmin .or. & Cloud_state%qa_in .le. qmin) endif +! --> h1g, 2019-09-19 + if( Constants_lsc%do_ncar_MG2 ) then + qr_too_small = (Cloud_state%qr_in .le. qmin .or. & + Cloud_state%qnr_in .le. qmin) + qs_too_small = (Cloud_state%qs_in .le. qmin .or. & + Cloud_state%qns_in .le. qmin) + endif +! <-- h1g, 2019-09-19 else if (do_liq_num) then ql_too_small = (Cloud_state%ql_in .le. qmin .or. & @@ -2104,7 +2211,7 @@ subroutine impose_realizability ( & ! predicted. if droplet number is not being predicted, values were ! set at allocation. !------------------------------------------------------------------------ - if (do_liq_num) then + if (do_liq_num .and. do_liq_num_fill ) then call adjust_particle_number (ql_too_small, Cloud_state%SN_out, & cloud_state%qn_in, Cloud_state%qn_upd) @@ -2175,6 +2282,67 @@ subroutine impose_realizability ( & call mpp_clock_end (lscloud_debug_clock) endif + + if ( Constants_lsc%do_ncar_MG2 ) then +!------------------------------------------------------------------------ +! call subroutine adjust_condensate to conservatively fill qr if needed. +!------------------------------------------------------------------------ + call adjust_condensate (qr_too_small, Cloud_state%SR_out, & + SQ_out, ST_out, Cloud_state%qr_in, HLV, Cloud_state%qr_upd) +!------------------------------------------------------------------------ +! save diagnostics defining the rain filling amount. +!------------------------------------------------------------------------ + if ( diag_id%qrdt_fill + diag_id%qr_fill_col > 0 ) then + where (qr_too_small ) + diag_4d(:,:,:,diag_pt%qrdt_fill) = & + -1.*Cloud_state%qr_in*inv_dtcloud + endwhere + end if + if ( diag_id%qdt_liquid_init > 0 ) then + where (qr_too_small ) + diag_4d(:,:,:,diag_pt%qdt_liquid_init) = diag_4d(:,:,:,diag_pt%qdt_liquid_init)+ & + Cloud_state%qr_in*inv_dtcloud + endwhere + end if + + call adjust_particle_number (qr_too_small, Cloud_state%SNR_out, & + Cloud_state%qnr_in, Cloud_state%qnr_upd) + if ( diag_id%qnrdt_fill + diag_id%qnr_fill_col > 0 ) then + where (qr_too_small ) + diag_4d(:,:,:,diag_pt%qnrdt_fill) = & + -1.*Cloud_state%qnr_in*inv_dtcloud + endwhere + end if + + +!------------------------------------------------------------------------ +! call subroutine adjust_condensate to conservatively fill qs if needed. +!------------------------------------------------------------------------ + call adjust_condensate (qs_too_small, Cloud_state%SS_out, & + SQ_out, ST_out, CLoud_state%qs_in, HLS, Cloud_state%qs_upd) + + if ( diag_id%qsdt_fill + diag_id%qs_fill_col > 0 ) then + where (qs_too_small ) + diag_4d(:,:,:,diag_pt%qsdt_fill) = & + -1.*Cloud_state%qs_in*inv_dtcloud + endwhere + end if + if ( diag_id%qdt_ice_init > 0 ) then + where (qs_too_small ) + diag_4d(:,:,:,diag_pt%qdt_ice_init) = diag_4d(:,:,:,diag_pt%qdt_ice_init)+ & + Cloud_state%qs_in*inv_dtcloud + endwhere + end if + call adjust_particle_number (qs_too_small, Cloud_state%SNS_out, & + Cloud_state%qns_in, Cloud_state%qns_upd) + if ( diag_id%qnsdt_fill + diag_id%qns_fill_col > 0 ) then + where (qs_too_small ) + diag_4d(:,:,:,diag_pt%qnsdt_fill) = & + -1.*Cloud_state%qns_in*inv_dtcloud + endwhere + end if + + endif ! do_ncar_MG2 !----------------------------------------------------------------------- @@ -2493,6 +2661,7 @@ subroutine detailed_diagnostics ( & + diag_4d(:,:,:,diag_pt%qldt_accrs) & + diag_4d(:,:,:,diag_pt%qldt_bergs) & + diag_4d(:,:,:,diag_pt%qldt_HM_splinter) & + + diag_4d(:,:,:,diag_pt%qldt_tiny) & ! h1g, 2020-06-25 - diag_4d(:,:,:,diag_pt%qidt_melt2 ) & - diag_4d(:,:,:,diag_pt%qidt_accrs) & - diag_4d(:,:,:,diag_pt%qdt_cleanup_liquid) & @@ -2519,6 +2688,8 @@ subroutine detailed_diagnostics ( & + diag_4d(:,:,:,diag_pt%qidt_accr) & + diag_4d(:,:,:,diag_pt%qidt_accrs) & + diag_4d(:,:,:,diag_pt%ice_adj ) & + + diag_4d(:,:,:,diag_pt%qidt_tiny) & ! h1g, 2020-06-25 + + diag_4d(:,:,:,diag_pt%qidt_rain2ice) & ! h1g, 2020-06-26 - diag_4d(:,:,:,diag_pt%qdt_cleanup_ice) & ) endif @@ -2544,6 +2715,7 @@ subroutine detailed_diagnostics ( & + diag_4d(:,:,:,diag_pt%qndt_size_adj) & + diag_4d(:,:,:,diag_pt%qndt_fill2) & + diag_4d(:,:,:,diag_pt%qndt_contact_frz) & + + diag_4d(:,:,:,diag_pt%qndt_tiny) & ! h1g, 2020-06-25 + diag_4d(:,:,:,diag_pt%qndt_cleanup) & + diag_4d(:,:,:,diag_pt%qndt_cleanup2) & ) @@ -2557,6 +2729,8 @@ subroutine detailed_diagnostics ( & + diag_4d(:,:,:,diag_pt%qnidt_nerosi) & + diag_4d(:,:,:,diag_pt%qnidt_nprci) & + diag_4d(:,:,:,diag_pt%qnidt_nprai) & + + diag_4d(:,:,:,diag_pt%qnidt_auto) & ! h1g, 2020-06-29 + + diag_4d(:,:,:,diag_pt%qnidt_accr) & ! h1g, 2020-06-29 + diag_4d(:,:,:,diag_pt%qnidt_nucclim1) & + diag_4d(:,:,:,diag_pt%qnidt_nucclim2) & + diag_4d(:,:,:,diag_pt%qnidt_sedi ) & @@ -2566,6 +2740,9 @@ subroutine detailed_diagnostics ( & + diag_4d(:,:,:,diag_pt%qnidt_super ) & + diag_4d(:,:,:,diag_pt%qnidt_ihom ) & + diag_4d(:,:,:,diag_pt%qnidt_destr ) & + + diag_4d(:,:,:,diag_pt%qnidt_tiny) & ! h1g, 2020-06-25 + + diag_4d(:,:,:,diag_pt%qnidt_rain2ice) & ! h1g, 2020-06-29 + - diag_4d(:,:,:,diag_pt%qndt_contact_frz) & ! h1g, 2020-06-29 + diag_4d(:,:,:,diag_pt%qnidt_cleanup) & + diag_4d(:,:,:,diag_pt%qnidt_cleanup2) & + diag_4d(:,:,:,diag_pt%qnidt_nsacwi) & @@ -2977,6 +3154,23 @@ subroutine update_fields_and_tendencies ( & Tend_mp%q_tnd(:,:,:,nql) Input_mp%tracer(:,:,:,nqi) = Input_mp%tracer(:,:,:,nqi) + & Tend_mp%q_tnd(:,:,:,nqi) +!--> h1g, 2019-08-27 --- + if( nqr /= NO_TRACER) & + Input_mp%tracer(:,:,:,nqr) = Input_mp%tracer(:,:,:,nqr) + & + Tend_mp%q_tnd(:,:,:,nqr) + if( nqs /= NO_TRACER) & + Input_mp%tracer(:,:,:,nqs) = Input_mp%tracer(:,:,:,nqs) + & + Tend_mp%q_tnd(:,:,:,nqs) + if( nqg /= NO_TRACER) & + Input_mp%tracer(:,:,:,nqg) = Input_mp%tracer(:,:,:,nqg) + & + Tend_mp%q_tnd(:,:,:,nqg) + if( nqnr /= NO_TRACER) & + Input_mp%tracer(:,:,:,nqnr) = Input_mp%tracer(:,:,:,nqnr) + & + Tend_mp%q_tnd(:,:,:,nqnr) + if( nqns /= NO_TRACER) & + Input_mp%tracer(:,:,:,nqns) = Input_mp%tracer(:,:,:,nqns) + & + Tend_mp%q_tnd(:,:,:,nqns) +!<-- h1g, 2019-08-27 ---- Input_mp%tracer(:,:,:,nqa) = Input_mp%tracer(:,:,:,nqa) + & Tend_mp%q_tnd(:,:,:,nqa) if (do_liq_num) & @@ -3000,6 +3194,24 @@ subroutine update_fields_and_tendencies ( & Time, is, js, 1) used = send_data (id_qlout, Input_mp%tracer(:,:,:,nql), & Time, is, js, 1) + if ( nqr /= NO_TRACER ) & + used = send_data (id_qrout, Input_mp%tracer(:,:,:,nqr), & + Time, is, js, 1) + if ( nqs /= NO_TRACER ) & + used = send_data (id_qsout, Input_mp%tracer(:,:,:,nqs), & + Time, is, js, 1) + if ( nqg /= NO_TRACER ) & + used = send_data (id_qgout, Input_mp%tracer(:,:,:,nqg), & + Time, is, js, 1) +!--> h1g, 2019-08-27 --- + if ( nqnr /= NO_TRACER ) & + used = send_data (id_qnrout, Input_mp%tracer(:,:,:,nqnr), & + Time, is, js, 1) + if ( nqns /= NO_TRACER ) & + used = send_data (id_qnsout, Input_mp%tracer(:,:,:,nqns), & + Time, is, js, 1) +!<-- h1g, 2019-08-27 ---- + used = send_data (id_qiout, Input_mp%tracer(:,:,:,nqi), & Time, is, js, 1) @@ -3022,6 +3234,19 @@ subroutine update_fields_and_tendencies ( & if (doing_prog_clouds) then Tend_mp%q_tnd(:,:,:,nql) = Tend_mp%q_tnd(:,:,:,nql)*dtinv Tend_mp%q_tnd(:,:,:,nqi) = Tend_mp%q_tnd(:,:,:,nqi)*dtinv + +!<-- h1g, 2019-08-27 ---- + if ( nqr /= NO_TRACER ) & + Tend_mp%q_tnd(:,:,:,nqr) = Tend_mp%q_tnd(:,:,:,nqr)*dtinv + if ( nqs /= NO_TRACER ) & + Tend_mp%q_tnd(:,:,:,nqs) = Tend_mp%q_tnd(:,:,:,nqs)*dtinv + if ( nqg /= NO_TRACER ) & + Tend_mp%q_tnd(:,:,:,nqg) = Tend_mp%q_tnd(:,:,:,nqg)*dtinv + if ( nqnr /= NO_TRACER ) & + Tend_mp%q_tnd(:,:,:,nqnr)= Tend_mp%q_tnd(:,:,:,nqnr)*dtinv + if ( nqns /= NO_TRACER ) & + Tend_mp%q_tnd(:,:,:,nqns)= Tend_mp%q_tnd(:,:,:,nqns)*dtinv +!<-- h1g, 2019-08-27 ---- Tend_mp%q_tnd(:,:,:,nqa) = Tend_mp%q_tnd(:,:,:,nqa)*dtinv if (do_liq_num) Tend_mp%q_tnd(:,:,:,nqn) = & Tend_mp%q_tnd(:,:,:,nqn)*dtinv @@ -3042,6 +3267,28 @@ subroutine update_fields_and_tendencies ( & Tend_mp%q_tnd(:,:,:,nql) Output_mp%rdt(:,:,:,nqi) = Output_mp%rdt(:,:,:,nqi) + & Tend_mp%q_tnd(:,:,:,nqi) + +!<-- h1g, 2019-08-27 ---- + if ( nqr /= NO_TRACER ) & + Output_mp%rdt(:,:,:,nqr) = Output_mp%rdt(:,:,:,nqr) + & + Tend_mp%q_tnd(:,:,:,nqr) + if ( nqs /= NO_TRACER ) & + Output_mp%rdt(:,:,:,nqs) = Output_mp%rdt(:,:,:,nqs) + & + Tend_mp%q_tnd(:,:,:,nqs) + if ( nqg /= NO_TRACER ) & + Output_mp%rdt(:,:,:,nqg) = Output_mp%rdt(:,:,:,nqg) + & + Tend_mp%q_tnd(:,:,:,nqg) +! if (mpp_pe() == mpp_root_pe() ) & +! write(*,*) 'before Output_mp nqr,nqs,nqg: ', nqr,nqs,nqg,NO_TRACER + + if ( nqnr /= NO_TRACER ) & + Output_mp%rdt(:,:,:,nqnr) = Output_mp%rdt(:,:,:,nqnr) + & + Tend_mp%q_tnd(:,:,:,nqnr) + if ( nqns /= NO_TRACER ) & + Output_mp%rdt(:,:,:,nqns) = Output_mp%rdt(:,:,:,nqns) + & + Tend_mp%q_tnd(:,:,:,nqns) +!<-- h1g, 2019-08-27 ---- + Output_mp%rdt(:,:,:,nqa) = Output_mp%rdt(:,:,:,nqa) + & Tend_mp%q_tnd(:,:,:,nqa) if (do_liq_num) & @@ -3060,6 +3307,7 @@ subroutine update_fields_and_tendencies ( & !---------------------------------------------------------------------- if (doing_prog_clouds) then Cld_props%cloud_area = Input_mp%tracer(:,:,:,nqa) + Cld_props%liquid_amt = Input_mp%tracer(:,:,:,nql) Cld_props%ice_amt = Input_mp%tracer(:,:,:,nqi) if (do_liq_num) & @@ -3086,8 +3334,6 @@ subroutine update_fields_and_tendencies ( & !---------------------------------------------------------------------- - - end subroutine update_fields_and_tendencies @@ -3123,6 +3369,12 @@ subroutine compute_ls_wetdep ( & integer :: kx logical :: used +!--> h1g, 2019-11-22 + integer :: i,j,k, ix, jx + ix= size(Input_mp%t,1) + jx= size(Input_mp%t,2) +!<-- h1g, 2019-11-22 + kx = size(Input_mp%t,3) !--------------------------------------------------------------------- @@ -3131,13 +3383,22 @@ subroutine compute_ls_wetdep ( & !--------------------------------------------------------------------- Tend_mp%qtnd_wet = Tend_mp%qtnd if (doing_prog_clouds) then - Tend_mp%qtnd_wet = Tend_mp%qtnd_wet + Tend_mp%q_tnd(:,:,:,nql) + & - Tend_mp%q_tnd(:,:,:,nqi) +!bqx + if (Constants_lsc%do_lin_cld_microphys) then + Tend_mp%qtnd_wet = Tend_mp%qtnd_wet + Tend_mp%q_tnd(:,:,:,nql) + & + Tend_mp%q_tnd(:,:,:,nqr) + & + Tend_mp%q_tnd(:,:,:,nqi) + & + Tend_mp%q_tnd(:,:,:,nqs) + & + Tend_mp%q_tnd(:,:,:,nqg) + else + Tend_mp%qtnd_wet = Tend_mp%qtnd_wet + Tend_mp%q_tnd(:,:,:,nql) + & + Tend_mp%q_tnd(:,:,:,nqi) + endif !----------------------------------------------------------------------- ! sum up the precipitation formed over timestep. !----------------------------------------------------------------------- - if (Constants_lsc%do_lin_cld_microphys) then + if (Constants_lsc%do_lin_cld_microphys .or. Constants_lsc%do_ncar_MG2 ) then C2ls_mp%cloud_wet = Input_mp%tracer(:,:,:,nqr) + & Input_mp%tracer(:,:,:,nqs) + & Input_mp%tracer(:,:,:,nqg) @@ -3193,9 +3454,14 @@ subroutine compute_ls_wetdep ( & n /= nqi .and. & n /= nqa .and. & n /= nqn .and. & - n /= nqni & + n /= nqni .and. & + n /= nqr .and. & + n /= nqs .and. & + n /= nqg & ) then Tend_mp%wetdeptnd(:,:,:) = 0.0 + + call wet_deposition ( & n, Input_mp%t, Input_mp%pfull, Input_mp%phalf, & Input_mp%zfull, Input_mp%zhalf, Precip_state%surfrain, & @@ -3212,7 +3478,6 @@ subroutine compute_ls_wetdep ( & !----------------------------------------------------------------------- Output_mp%rdt (:,:,:,n) = Output_mp%rdt(:,:,:,n) - & Tend_mp%wetdeptnd(:,:,:) - !----------------------------------------------------------------------- ! add the large-scale wet deposition tendency for the tracer to the ! previously-obtained convective wet deposition tendency @@ -3492,21 +3757,42 @@ subroutine lscloud_dealloc (Atmos_state, Particles, Cloud_State, & deallocate (Cloud_state%qa_upd ) deallocate (Cloud_state%qn_upd ) deallocate (Cloud_state%qni_upd ) + deallocate (Cloud_state%qr_upd ) + deallocate (Cloud_state%qs_upd ) + deallocate (Cloud_state%qnr_upd ) + deallocate (Cloud_state%qns_upd ) + deallocate (Cloud_state%ql_mean ) deallocate (Cloud_state%qi_mean ) deallocate (Cloud_state%qa_mean ) deallocate (Cloud_state%qn_mean ) deallocate (Cloud_state%qni_mean) + deallocate (Cloud_state%qr_mean ) + deallocate (Cloud_state%qs_mean ) + deallocate (Cloud_state%qnr_mean) + deallocate (Cloud_state%qns_mean) + deallocate (Cloud_state%ql_in ) + deallocate (Cloud_state%qr_in ) deallocate (Cloud_state%qi_in ) + deallocate (Cloud_state%qs_in ) + deallocate (Cloud_state%qg_in ) deallocate (Cloud_state%qa_in ) deallocate (Cloud_state%qn_in ) deallocate (Cloud_state%qni_in ) + deallocate (Cloud_state%qnr_in ) + deallocate (Cloud_state%qns_in ) + deallocate (Cloud_state%SL_out ) deallocate (Cloud_state%SI_out ) deallocate (Cloud_state%SA_out ) deallocate (Cloud_state%SN_out ) deallocate (Cloud_state%SNi_out ) + deallocate (Cloud_state%SR_out ) + deallocate (Cloud_state%SS_out ) + deallocate (Cloud_state%SNR_out ) + deallocate (Cloud_state%SNS_out ) + deallocate (Cloud_state%qcvar_clubb ) deallocate (Cloud_state%relvarn ) deallocate (Cloud_state%qa_upd_0) diff --git a/atmos_param/lscloud_driver/lscloud_netcdf.F90 b/atmos_param/lscloud_driver/lscloud_netcdf.F90 index a208ff2c..98291ffe 100644 --- a/atmos_param/lscloud_driver/lscloud_netcdf.F90 +++ b/atmos_param/lscloud_driver/lscloud_netcdf.F90 @@ -229,7 +229,7 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & Time, is, js, 1) used = send_data & (diag_id%a_snow_clr, diag_4d_kp1(:,:,:,diag_pt%a_snow_clr),& - Time, is, js, 1) + Time, is, js, 1) used = send_data & (diag_id%snow_cld, diag_4d_kp1(:,:,:,diag_pt%snow_cld), & Time, is, js, 1) @@ -278,6 +278,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qldt_fill, diag_4d(:,:,:,diag_pt%qldt_fill), & Time, is, js, 1) + used = send_data & + (diag_id%qldt_tiny, diag_4d(:,:,:,diag_pt%qldt_tiny), & + Time, is, js, 1) used = send_data & (diag_id%qldt_berg, diag_4d(:,:,:,diag_pt%qldt_berg), & Time, is, js, 1) @@ -315,6 +318,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qndt_fill, diag_4d(:,:,:,diag_pt%qndt_fill), & Time, is, js, 1) + used = send_data & + (diag_id%qndt_tiny, diag_4d(:,:,:,diag_pt%qndt_tiny), & + Time, is, js, 1) used = send_data & (diag_id%qndt_destr, diag_4d(:,:,:,diag_pt%qndt_destr), & Time, is, js, 1) @@ -370,6 +376,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qnidt_fill, diag_4d(:,:,:,diag_pt%qnidt_fill), & Time, is, js, 1) + used = send_data & + (diag_id%qnidt_tiny, diag_4d(:,:,:,diag_pt%qnidt_tiny), & + Time, is, js, 1) used = send_data & (diag_id%qnidt_nnuccd, diag_4d(:,:,:,diag_pt%qnidt_nnuccd), & Time, is, js, 1) @@ -379,6 +388,12 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qnidt_nerosi, diag_4d(:,:,:,diag_pt%qnidt_nerosi), & Time, is, js, 1) + used = send_data & + (diag_id%qnidt_auto, diag_4d(:,:,:,diag_pt%qnidt_auto), & + Time, is, js, 1) + used = send_data & + (diag_id%qnidt_accr, diag_4d(:,:,:,diag_pt%qnidt_accr), & + Time, is, js, 1) used = send_data & (diag_id%qnidt_nprci, diag_4d(:,:,:,diag_pt%qnidt_nprci), & Time, is, js, 1) @@ -412,6 +427,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qnidt_ihom, diag_4d(:,:,:,diag_pt%qnidt_ihom), & Time, is, js, 1) + used = send_data & + (diag_id%qnidt_rain2ice, diag_4d(:,:,:,diag_pt%qnidt_rain2ice), & + Time, is, js, 1) used = send_data & (diag_id%qnidt_destr, diag_4d(:,:,:,diag_pt%qnidt_destr), & Time, is, js, 1) @@ -525,6 +543,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qidt_fill, diag_4d(:,:,:,diag_pt%qidt_fill), & Time, is, js, 1) + used = send_data & + (diag_id%qidt_tiny, diag_4d(:,:,:,diag_pt%qidt_tiny), & + Time, is, js, 1) used = send_data & (diag_id%qidt_auto, diag_4d(:,:,:,diag_pt%qidt_auto), & Time, is, js, 1) @@ -534,6 +555,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qidt_accrs, diag_4d(:,:,:,diag_pt%qidt_accrs), & Time, is, js, 1) + used = send_data & + (diag_id%qidt_rain2ice, diag_4d(:,:,:,diag_pt%qidt_rain2ice), & + Time, is, js, 1) !----------------------------------------------------------------------- ! 15) variables associated with cloud area tendency: @@ -668,6 +692,53 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & diag_4d(:,:,:,diag_pt%qldt_HM_splinter), & Time, is, js, 1) +!------------------------------------------------------------------------ +! variables with MG2 +!------------------------------------------------------------------------ + used = send_data ( diag_id%SR3d, diag_4d(:,:,:,diag_pt%SR3d), & + Time, is, js, 1) + used = send_data ( diag_id%SNR3d, diag_4d(:,:,:,diag_pt%SNR3d), & + Time, is, js, 1) + used = send_data ( diag_id%SS3d, diag_4d(:,:,:,diag_pt%SS3d), & + Time, is, js, 1) + used = send_data ( diag_id%SNS3d, diag_4d(:,:,:,diag_pt%SNS3d), & + Time, is, js, 1) + + + used = send_data ( diag_id%rain_inst, diag_4d(:,:,:,diag_pt%rain_inst), & + Time, is, js, 1) + used = send_data ( diag_id%rain_sedi, diag_4d(:,:,:,diag_pt%rain_sedi), & + Time, is, js, 1) + used = send_data ( diag_id%rain_num_inst, diag_4d(:,:,:,diag_pt%rain_num_inst), & + Time, is, js, 1) + used = send_data ( diag_id%rain_num_sedi, diag_4d(:,:,:,diag_pt%rain_num_sedi), & + Time, is, js, 1) + used = send_data ( diag_id%rain_num_adj, diag_4d(:,:,:,diag_pt%rain_num_adj), & + Time, is, js, 1) + used = send_data ( diag_id%rain_num2snow, diag_4d(:,:,:,diag_pt%rain_num2snow), & + Time, is, js, 1) + used = send_data ( diag_id%rain_num_evap, diag_4d(:,:,:,diag_pt%rain_num_evap), & + Time, is, js, 1) + used = send_data ( diag_id%rain_num_freez, diag_4d(:,:,:,diag_pt%rain_num_freez), & + Time, is, js, 1) + used = send_data ( diag_id%rain_num_selfcoll, diag_4d(:,:,:,diag_pt%rain_num_selfcoll), & + Time, is, js, 1) + + + used = send_data ( diag_id%snow_inst, diag_4d(:,:,:,diag_pt%snow_inst), & + Time, is, js, 1) + used = send_data ( diag_id%snow_sedi, diag_4d(:,:,:,diag_pt%snow_sedi), & + Time, is, js, 1) + used = send_data ( diag_id%snow_num_inst, diag_4d(:,:,:,diag_pt%snow_num_inst), & + Time, is, js, 1) + used = send_data ( diag_id%snow_num_sedi, diag_4d(:,:,:,diag_pt%snow_num_sedi), & + Time, is, js, 1) + used = send_data ( diag_id%snow_num_melt, diag_4d(:,:,:,diag_pt%snow_num_melt), & + Time, is, js, 1) + used = send_data ( diag_id%snow_num_adj, diag_4d(:,:,:,diag_pt%snow_num_adj), & + Time, is, js, 1) + + !----------------------------------------------------------------------- ! 17) variables associated with budget verification: !----------------------------------------------------------------------- @@ -685,24 +756,50 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & Time, is, js, 1) used = send_data ( diag_id%SNi_imb, diag_4d(:,:,:,diag_pt%SNi_imb), & Time, is, js, 1) + used = send_data ( diag_id%rain_imb, diag_4d(:,:,:,diag_pt%rain_imb),& + Time, is, js, 1) used = send_data ( diag_id%cld_liq_imb, & diag_4d(:,:,:,diag_pt%cld_liq_imb), & Time, is, js, 1) + used = send_data ( diag_id%snow_imb, & + diag_4d(:,:,:,diag_pt%snow_imb), & + Time, is, js, 1) used = send_data ( diag_id%cld_ice_imb, & diag_4d(:,:,:,diag_pt%cld_ice_imb), & Time, is, js, 1) !----------------------------------------------------------------------- -! 18) variables associated CMIP diagnostics +! 18) variables associated prognostic precipitation !----------------------------------------------------------------------- - if (query_cmip_diag_id(diag_id%cdnc)) then - used = send_cmip_data_3d ( diag_id%cdnc, & - 1.e06*diag_4d(:,:,:,diag_pt%droplets), & - Time, is, js, 1, mask=diag_4d(:,:,:,diag_pt%droplets) > 0.0) - endif + used = send_data & + (diag_id%qrdt_fill, diag_4d(:,:,:,diag_pt%qrdt_fill), & + Time, is, js, 1) + used = send_data & + (diag_id%qnrdt_fill, diag_4d(:,:,:,diag_pt%qnrdt_fill), & + Time, is, js, 1) + used = send_data & + (diag_id%qrdt_tiny, diag_4d(:,:,:,diag_pt%qrdt_tiny), & + Time, is, js, 1) + used = send_data & + (diag_id%qnrdt_tiny, diag_4d(:,:,:,diag_pt%qnrdt_tiny), & + Time, is, js, 1) + + used = send_data & + (diag_id%qsdt_fill, diag_4d(:,:,:,diag_pt%qsdt_fill), & + Time, is, js, 1) + used = send_data & + (diag_id%qnsdt_fill, diag_4d(:,:,:,diag_pt%qnsdt_fill), & + Time, is, js, 1) + used = send_data & + (diag_id%qsdt_tiny, diag_4d(:,:,:,diag_pt%qsdt_tiny), & + Time, is, js, 1) + used = send_data & + (diag_id%qnsdt_tiny, diag_4d(:,:,:,diag_pt%qnsdt_tiny), & + Time, is, js, 1) + !----------------------------------------------------------------------- -! 18) variables associated CMIP diagnostics +! 19) variables associated CMIP diagnostics !----------------------------------------------------------------------- if (query_cmip_diag_id(diag_id%cdnc)) then used = send_cmip_data_3d ( diag_id%cdnc, & @@ -806,6 +903,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%ql_fill_col, diag_3d(:,:, diag_pt%qldt_fill), & Time, is, js) + used = send_data & + (diag_id%ql_tiny_col, diag_3d(:,:, diag_pt%qldt_tiny), & + Time, is, js) used = send_data & (diag_id%liq_adj_col, diag_3d(:,:, diag_pt%liq_adj), & Time, is, js) @@ -834,6 +934,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qn_fill_col, diag_3d(:,:, diag_pt%qndt_fill), & Time, is, js) + used = send_data & + (diag_id%qn_tiny_col, diag_3d(:,:, diag_pt%qndt_tiny), & + Time, is, js) used = send_data & (diag_id%qn_berg_col, diag_3d(:,:, diag_pt%qndt_berg), & Time, is, js) @@ -912,6 +1015,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qi_fill_col, diag_3d(:,:, diag_pt%qidt_fill), & Time, is, js) + used = send_data & + (diag_id%qi_tiny_col, diag_3d(:,:, diag_pt%qidt_tiny), & + Time, is, js) used = send_data & (diag_id%qi_dep_col, diag_3d(:,:, diag_pt%qidt_dep), & Time, is, js) @@ -945,6 +1051,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qi_accrs_col, diag_3d(:,:, diag_pt%qidt_accrs), & Time, is, js) + used = send_data & + (diag_id%qi_rain2ice_col, diag_3d(:,:, diag_pt%qidt_rain2ice), & + Time, is, js) !----------------------------------------------------------------------- ! 15) variables associated with cloud area time tendency: @@ -1033,6 +1142,18 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data (diag_id%ql_HM_splinter_col, & diag_3d(:,:,diag_pt%qldt_HM_splinter), Time, is, js ) +!------------------------------------------------------------------------ +! variables with MG2 +!------------------------------------------------------------------------ + used = send_data ( diag_id%SR2d, diag_3d(:,:,diag_pt%SR3d), & + Time, is, js ) + used = send_data ( diag_id%SNR2d, diag_3d(:,:,diag_pt%SNR3d), & + Time, is, js ) + used = send_data ( diag_id%SS2d, diag_3d(:,:,diag_pt%SS3d), & + Time, is, js ) + used = send_data ( diag_id%SNS2d, diag_3d(:,:,diag_pt%SNS3d), & + Time, is, js ) + !----------------------------------------------------------------------- ! 17) variables associated with budget verification: !----------------------------------------------------------------------- @@ -1069,6 +1190,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qni_fill_col, diag_3d(:,:,diag_pt%qnidt_fill), & Time, is, js) + used = send_data & + (diag_id%qni_tiny_col, diag_3d(:,:,diag_pt%qnidt_tiny), & + Time, is, js) used = send_data & (diag_id%qni_nnuccd_col, diag_3d(:,:,diag_pt%qnidt_nnuccd), & Time, is, js) @@ -1078,6 +1202,12 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qni_nerosi_col, diag_3d(:,:,diag_pt%qnidt_nerosi), & Time, is, js) + used = send_data & + (diag_id%qni_auto_col, diag_3d(:,:,diag_pt%qnidt_auto), & + Time, is, js) + used = send_data & + (diag_id%qni_accr_col, diag_3d(:,:,diag_pt%qnidt_accr), & + Time, is, js) used = send_data & (diag_id%qni_nprci_col, diag_3d(:,:,diag_pt%qnidt_nprci), & Time, is, js) @@ -1111,6 +1241,9 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & used = send_data & (diag_id%qni_ihom_col, diag_3d(:,:,diag_pt%qnidt_ihom), & Time, is, js) + used = send_data & + (diag_id%qni_rain2ice_col, diag_3d(:,:,diag_pt%qnidt_rain2ice), & + Time, is, js) used = send_data & (diag_id%qni_destr_col, diag_3d(:,:,diag_pt%qnidt_destr), & Time, is, js) @@ -1127,6 +1260,69 @@ subroutine lscloud_netcdf (diag_id, diag_pt, diag_4d, diag_4d_kp1, & diag_3d(:,:,diag_pt%qnidt_cleanup2), & Time, is, js) + +!----------------------------------------------------------------------- +! 18) variables associated with prognostic precipitation: +!----------------------------------------------------------------------- + used = send_data & + (diag_id%qr_fill_col, diag_3d(:,:,diag_pt%qrdt_fill), & + Time, is, js ) + used = send_data & + (diag_id%qnr_fill_col, diag_3d(:,:,diag_pt%qnrdt_fill), & + Time, is, js ) + used = send_data & + (diag_id%qr_tiny_col, diag_3d(:,:,diag_pt%qrdt_tiny), & + Time, is, js ) + used = send_data & + (diag_id%qnr_tiny_col, diag_3d(:,:,diag_pt%qnrdt_tiny), & + Time, is, js ) + + used = send_data & + (diag_id%qs_fill_col, diag_3d(:,:,diag_pt%qsdt_fill), & + Time, is, js ) + used = send_data & + (diag_id%qns_fill_col, diag_3d(:,:,diag_pt%qnsdt_fill), & + Time, is, js ) + used = send_data & + (diag_id%qs_tiny_col, diag_3d(:,:,diag_pt%qsdt_tiny), & + Time, is, js ) + used = send_data & + (diag_id%qns_tiny_col, diag_3d(:,:,diag_pt%qnsdt_tiny), & + Time, is, js ) + + + used = send_data ( diag_id%rain_inst_col, diag_3d(:,:,diag_pt%rain_inst), & + Time, is, js ) + used = send_data ( diag_id%rain_sedi_col, diag_3d(:,:,diag_pt%rain_sedi), & + Time, is, js ) + used = send_data ( diag_id%rain_num_inst_col, diag_3d(:,:,diag_pt%rain_num_inst), & + Time, is, js ) + used = send_data ( diag_id%rain_num_sedi_col, diag_3d(:,:,diag_pt%rain_num_sedi), & + Time, is, js ) + used = send_data ( diag_id%rain_num_adj_col, diag_3d(:,:,diag_pt%rain_num_adj), & + Time, is, js ) + used = send_data ( diag_id%rain_num2snow_col, diag_3d(:,:,diag_pt%rain_num2snow), & + Time, is, js ) + used = send_data ( diag_id%rain_num_evap_col, diag_3d(:,:,diag_pt%rain_num_evap), & + Time, is, js ) + used = send_data ( diag_id%rain_num_freez_col, diag_3d(:,:,diag_pt%rain_num_freez), & + Time, is, js ) + used = send_data ( diag_id%rain_num_selfcoll_col, diag_3d(:,:,diag_pt%rain_num_selfcoll), & + Time, is, js ) + + + used = send_data ( diag_id%snow_inst_col, diag_3d(:,:,diag_pt%snow_inst), & + Time, is, js ) + used = send_data ( diag_id%snow_sedi_col, diag_3d(:,:,diag_pt%snow_sedi), & + Time, is, js ) + used = send_data ( diag_id%snow_num_inst_col, diag_3d(:,:,diag_pt%snow_num_inst), & + Time, is, js ) + used = send_data ( diag_id%snow_num_sedi_col, diag_3d(:,:,diag_pt%snow_num_sedi), & + Time, is, js ) + used = send_data ( diag_id%snow_num_melt_col, diag_3d(:,:,diag_pt%snow_num_melt), & + Time, is, js ) + used = send_data ( diag_id%snow_num_adj_col, diag_3d(:,:,diag_pt%snow_num_adj), & + Time, is, js ) !------------------------------------------------------------------------ @@ -1414,6 +1610,12 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'Liquid water specific humidity tendency -- & &pre-microphysics filler', & 'kg/kg/sec', missing_value=missing_value) + diag_id%qldt_tiny = register_diag_field (mod_name, & + 'qldt_tiny', axes(1:3), Time, & + 'Liquid water specific humidity tendency -- & + & in-microphysics substep (tiny or negative) liquid water filler', & + 'kg/kg/sec', missing_value=missing_value) + diag_id%qldt_berg = register_diag_field (mod_name, & 'qldt_berg', axes(1:3), Time, & 'Liq water specific humidity tendency from Bergeron process',& @@ -1477,6 +1679,10 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'qndt_fill', axes(1:3), Time, & 'Cloud droplet number tendency from filler', '#/kg/sec', & missing_value=missing_value) + diag_id%qndt_tiny = register_diag_field (mod_name, & + 'qndt_tiny', axes(1:3), Time, & + 'Cloud droplet number tendency from microphysics sub-step filler', '#/kg/sec', & + missing_value=missing_value) diag_id%qndt_destr = register_diag_field (mod_name, & 'qndt_destr', axes(1:3), Time, & 'Cloud droplet number tendency from cloud destruction', & @@ -1559,7 +1765,11 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & diag_id%qnidt_fill = register_diag_field (mod_name, & 'qnidt_fill', axes(1:3), Time, & 'Ice particle number tendency from filler', '#/kg/sec', & - missing_value=missing_value) + missing_value=missing_value) + diag_id%qnidt_tiny = register_diag_field (mod_name, & + 'qnidt_tiny', axes(1:3), Time, & + 'Ice particle number tendency from microphysics substep filler', '#/kg/sec', & + missing_value=missing_value) diag_id%qnidt_nnuccd = register_diag_field (mod_name, & 'qnidt_nnuccd', axes(1:3), Time, & 'Ice particle number tendency from nucleation', '#/kg/sec', & @@ -1572,6 +1782,14 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'qnidt_nerosi', axes(1:3), Time, & 'Ice particle number tendency from erosion', '#/kg/sec', & missing_value=missing_value) + diag_id%qnidt_auto = register_diag_field (mod_name, & + 'qnidt_auto', axes(1:3), Time, & + 'Ice particle number tendency from autoconversion', & + '#/kg/sec', missing_value=missing_value) + diag_id%qnidt_accr = register_diag_field (mod_name, & + 'qnidt_accr', axes(1:3), Time, & + 'Ice particle number tendency from accretion by snow', & + '#/kg/sec', missing_value=missing_value) diag_id%qnidt_nprci = register_diag_field (mod_name, & 'qnidt_nprci', axes(1:3), Time, & 'Ice particle number tendency from autoconversion', & @@ -1611,7 +1829,11 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & diag_id%qnidt_ihom = register_diag_field (mod_name, & 'qnidt_ihom', axes(1:3), Time, & 'Ice particle number tendency from homogeneous freezing', & - '#/kg/sec', missing_value=missing_value) + '#/kg/sec', missing_value=missing_value) + diag_id%qnidt_rain2ice = register_diag_field (mod_name, & + 'qnidt_rain2ice', axes(1:3), Time, & + 'Ice particle number tendency from converting rain to ice', & + '#/kg/sec', missing_value=missing_value) diag_id%qnidt_destr = register_diag_field (mod_name, & 'qnidt_destr', axes(1:3), Time, & 'Ice particle number tendency from cloud destruction', & @@ -1754,6 +1976,10 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'qidt_fill', axes(1:3), Time, & 'Ice water specific humidity tendency -- pre-microphysics & & filler', 'kg/kg/sec', missing_value=missing_value) + diag_id%qidt_tiny = register_diag_field (mod_name, & + 'qidt_tiny', axes(1:3), Time, & + 'Ice water specific humidity tendency -- in microphysics substep & + & filler', 'kg/kg/sec', missing_value=missing_value) diag_id%qidt_auto = register_diag_field (mod_name, & 'qidt_auto', axes(1:3), Time, & 'Ice water specific humidity tendency from autoconversion & @@ -1766,6 +1992,11 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'qidt_accrs', axes(1:3), Time, & 'Ice wat spec hum tend from selfcollection (1 class scheme)',& 'kg/kg/sec', missing_value=missing_value) + diag_id%qidt_rain2ice = register_diag_field (mod_name, & + 'qidt_rain2ice', axes(1:3), Time, & + 'Ice wat spec hum tend from freezing rain to form ice ',& + 'kg/kg/sec', missing_value=missing_value) + !----------------------------------------------------------------------- ! 15) variables associated with cloud area time tendency: @@ -1935,11 +2166,98 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'srfrain_freez', axes(1:3), Time, & 'rain water sink from freezing', & 'kg/kg/sec', missing_value=missing_value) + + diag_id%rain_inst= register_diag_field ( mod_name, & + 'rain_inst', axes(1:3), Time, & + 'rain water instantaneous freezing/melting ', & + 'kg/kg/sec', missing_value=missing_value) + + diag_id%rain_sedi= register_diag_field ( mod_name, & + 'rain_sedi', axes(1:3), Time, & + 'rain water sedimentation ', & + 'kg/kg/sec', missing_value=missing_value) + + diag_id%rain_num_inst= register_diag_field ( mod_name, & + 'rain_num_inst', axes(1:3), Time, & + 'rain number instantaneous freezing/melting ', & + '#/kg/sec', missing_value=missing_value) + + diag_id%rain_num_sedi= register_diag_field ( mod_name, & + 'rain_num_sedi', axes(1:3), Time, & + 'rain number sedimentation ', & + '#/kg/sec', missing_value=missing_value) + diag_id%rain_num_adj= register_diag_field ( mod_name, & + 'rain_num_adj', axes(1:3), Time, & + 'rain number change due to rain size adjustment ', & + '#/kg/sec', missing_value=missing_value) + diag_id%rain_num2snow= register_diag_field ( mod_name, & + 'rain_num2snow', axes(1:3), Time, & + 'rain number change due to rain freezing to snow ', & + '#/kg/sec', missing_value=missing_value) + diag_id%rain_num_evap= register_diag_field ( mod_name, & + 'rain_num_evap', axes(1:3), Time, & + 'rain number change due to rain evaporation ', & + '#/kg/sec', missing_value=missing_value) + diag_id%rain_num_freez= register_diag_field ( mod_name, & + 'rain_num_freez', axes(1:3), Time, & + 'rain number change due to rain homogeneous freezing ', & + '#/kg/sec', missing_value=missing_value) + diag_id%rain_num_selfcoll= register_diag_field ( mod_name, & + 'rain_num_selfcoll', axes(1:3), Time, & + 'rain number change due to rain self collection ', & + '#/kg/sec', missing_value=missing_value) + + + diag_id%snow_inst= register_diag_field ( mod_name, & + 'snow_inst', axes(1:3), Time, & + 'snow instantaneous freezing/melting ', & + 'kg/kg/sec', missing_value=missing_value) + diag_id%snow_sedi= register_diag_field ( mod_name, & + 'snow_sedi', axes(1:3), Time, & + 'snow sedimentation ', & + 'kg/kg/sec', missing_value=missing_value) + diag_id%snow_num_inst= register_diag_field ( mod_name, & + 'snow_num_inst', axes(1:3), Time, & + 'snow number instantaneous freezing/melting ', & + '#/kg/sec', missing_value=missing_value) + diag_id%snow_num_sedi= register_diag_field ( mod_name, & + 'snow_num_sedi', axes(1:3), Time, & + 'snow number sedimentation ', & + '#/kg/sec', missing_value=missing_value) + diag_id%snow_num_melt= register_diag_field ( mod_name, & + 'snow_num_melt', axes(1:3), Time, & + 'snow number melt ', & + '#/kg/sec', missing_value=missing_value) + diag_id%snow_num_adj= register_diag_field ( mod_name, & + 'snow_num_adj', axes(1:3), Time, & + 'snow number change due to snow size adjustment ', & + '#/kg/sec', missing_value=missing_value) + diag_id%SI3d = register_diag_field ( mod_name, & 'SI3d', axes(1:3), Time, & 'Total Ice water specific humidity tendency ', & 'kg/kg/sec', missing_value=missing_value) + diag_id%SR3d = register_diag_field ( mod_name, & + 'SR3d', axes(1:3), Time, & + 'Total Rain Water specific humidity tendency ', & + 'kg/kg/sec', missing_value=missing_value) + + diag_id%SNR3d = register_diag_field ( mod_name, & + 'SNR3d', axes(1:3), Time, & + 'Total Rain drop number specific humidity tendency ', & + '#/kg/sec', missing_value=missing_value) + + diag_id%SS3d = register_diag_field ( mod_name, & + 'SS3d', axes(1:3), Time, & + 'Total Snow Water specific humidity tendency ', & + 'kg/kg/sec', missing_value=missing_value) + + diag_id%SNS3d = register_diag_field ( mod_name, & + 'SNS3d', axes(1:3), Time, & + 'Total Snow particle number specific humidity tendency ', & + 'kg/kg/sec', missing_value=missing_value) + !------------------------------------------------------------------------ ! 17) variables associated with budget analysis !------------------------------------------------------------------------ @@ -1971,17 +2289,102 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'SNi_imb', axes(1:3), Time, & 'difference between qni tendency and sum of individ terms', & '#/kg/sec', missing_value=missing_value) + diag_id%rain_imb = register_diag_field ( mod_name, & + 'rain_imb', axes(1:3), Time, & + 'difference between rain rate at sfc and sum of & + &individ terms', 'kg/kg/sec', missing_value=missing_value) diag_id%cld_liq_imb = register_diag_field ( mod_name, & 'cld_liq_imb', axes(1:3), Time, & 'difference between ql fallout rate at sfc and sum of & &individ terms', 'kg/kg/sec', missing_value=missing_value) + diag_id%snow_imb = register_diag_field ( mod_name, & + 'snow_imb', axes(1:3), Time, & + 'difference between snow rate at sfc and sum of & + &individ terms', 'kg/kg/sec', missing_value=missing_value) diag_id%cld_ice_imb = register_diag_field ( mod_name, & 'cld_ice_imb', axes(1:3), Time, & 'difference between qi fallout rate at sfc and sum of & &individ terms', 'kg/kg/sec', missing_value=missing_value) !------------------------------------------------------------------------ - ! 18) variables associated CMIP diagnostics + ! 18) variables associated prognostic precipitation + !------------------------------------------------------------------------ + diag_id%qrdt_fill = register_diag_field (mod_name, & + 'qrdt_fill', axes(1:3), Time, & + 'Rain water specific humidity tendency -- & + &pre-microphysics filler', & + 'kg/kg/sec', missing_value=missing_value) + + diag_id%qnrdt_fill = register_diag_field (mod_name, & + 'qnrdt_fill', axes(1:3), Time, & + 'Rain drop number concentration tendency -- & + &pre-microphysics filler', & + '#/kg/sec', missing_value=missing_value) + + diag_id%qrdt_tiny = register_diag_field (mod_name, & + 'qrdt_tiny', axes(1:3), Time, & + 'Rain water specific humidity tendency -- & + &in-microphysics sub-step filler', & + 'kg/kg/sec', missing_value=missing_value) + + diag_id%qnrdt_tiny = register_diag_field (mod_name, & + 'qnrdt_tiny', axes(1:3), Time, & + 'Rain drop number concentration tendency -- & + &in-microphysics sub-step filler', & + '#/kg/sec', missing_value=missing_value) + + diag_id%qsdt_fill = register_diag_field (mod_name, & + 'qsdt_fill', axes(1:3), Time, & + 'Snow specific humidity tendency -- & + &pre-microphysics filler', & + 'kg/kg/sec', missing_value=missing_value) + + diag_id%qnsdt_fill = register_diag_field (mod_name, & + 'qnsdt_fill', axes(1:3), Time, & + 'Snow number concentration tendency -- & + &pre-microphysics filler', & + '#/kg/sec', missing_value=missing_value) + + diag_id%qsdt_tiny = register_diag_field (mod_name, & + 'qsdt_tiny', axes(1:3), Time, & + 'Snow specific humidity tendency -- & + &in-microphysics substep filler', & + 'kg/kg/sec', missing_value=missing_value) + + diag_id%qnsdt_tiny = register_diag_field (mod_name, & + 'qnsdt_tiny', axes(1:3), Time, & + 'Snow number concentration tendency -- & + &in-microphysics substep filler', & + '#/kg/sec', missing_value=missing_value) + + diag_id%qrdt_destr = register_diag_field (mod_name, & + 'qrdt_destr', axes(1:3), Time, & + 'Rain water specific humidity tendency -- & + &after microphysics destruction', & + 'kg/kg/sec', missing_value=missing_value) + + diag_id%qnrdt_destr = register_diag_field (mod_name, & + 'qnrdt_destr', axes(1:3), Time, & + 'Rain drop number concentration tendency -- & + &after microphysics destruction', & + '#/kg/sec', missing_value=missing_value) + + diag_id%qsdt_destr = register_diag_field (mod_name, & + 'qsdt_destr', axes(1:3), Time, & + 'Snow specific humidity tendency -- & + &after microphysics destruction', & + 'kg/kg/sec', missing_value=missing_value) + + diag_id%qnsdt_destr = register_diag_field (mod_name, & + 'qnsdt_destr', axes(1:3), Time, & + 'Snow number concentration tendency -- & + &after microphysics destruction', & + '#/kg/sec', missing_value=missing_value) + + + + !------------------------------------------------------------------------ + ! 19) variables associated CMIP diagnostics !------------------------------------------------------------------------ diag_id%cdnc = register_cmip_diag_field_3d ( mod_name, 'cdnc', Time, & 'Cloud Droplet Number Concentration', 'm-3', mask_variant=.true., & @@ -2092,6 +2495,10 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'ql_fill_col', axes(1:2), Time, & 'Column integrated pre-microphysics liquid filler', & 'kg/m2/sec', missing_value=missing_value) + diag_id%ql_tiny_col = register_diag_field (mod_name, & + 'ql_tiny_col', axes(1:2), Time, & + 'Column integrated in-microphysics substep (tiny or negative) liquid filler', & + 'kg/m2/sec', missing_value=missing_value) diag_id%liq_adj_col = register_diag_field (mod_name, & 'liq_adj_col', axes(1:2), Time, & 'Column integrated liquid water specific humidity & @@ -2139,6 +2546,10 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'qn_fill_col', axes(1:2), Time, & 'Column integrated drop number filler', '#/m2/sec', & missing_value=missing_value) + diag_id%qn_tiny_col = register_diag_field (mod_name, & + 'qn_tiny_col', axes(1:2), Time, & + 'Column integrated drop number in-microphysics substep filler', '#/m2/sec', & + missing_value=missing_value) diag_id%qn_destr_col = register_diag_field (mod_name, & 'qn_destr_col', axes(1:2), Time, & 'Column integrated drop number destruction', '#/m2/sec', & @@ -2233,6 +2644,10 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'qi_fill_col', axes(1:2), Time, & 'Column integrated pre-microphysics ice filler', 'kg/m2/sec',& missing_value=missing_value) + diag_id%qi_tiny_col = register_diag_field (mod_name, & + 'qi_tiny_col', axes(1:2), Time, & + 'Column integrated in microphysics substep ice filler', 'kg/m2/sec',& + missing_value=missing_value) diag_id%qi_dep_col = register_diag_field (mod_name, & 'qi_dep_col', axes(1:2), Time, & 'Column integrated large-scale deposition', 'kg/m2/sec', & @@ -2278,6 +2693,10 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'qi_accrs_col', axes(1:2), Time, & 'Column integrated self collection (one class scheme)', & 'kg/m2/sec', missing_value=missing_value) + diag_id%qi_rain2ice_col = register_diag_field (mod_name, & + 'qi_rain2ice_col', axes(1:2), Time, & + 'Column integrated ice from freezing rain ', & + 'kg/m2/sec', missing_value=missing_value) !----------------------------------------------------------------------- ! 15) variables associated with cloud area time tendency: @@ -2353,6 +2772,24 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'SNI2d', axes(1:2), Time, & 'Column integrated total ice crystal number tendency', & '#/m2/sec', missing_value=missing_value) + + diag_id%SR2d = register_diag_field ( mod_name, & + 'SR2d', axes(1:2), Time, & + 'Column integrated total Rain Water specific humidity', & + 'kg/m2/sec', missing_value=missing_value) + diag_id%SNR2d = register_diag_field ( mod_name, & + 'SNR2d', axes(1:2), Time, & + 'Column integrated total Rain drop number specific humidity', & + '#/m2/sec', missing_value=missing_value) + diag_id%SS2d = register_diag_field ( mod_name, & + 'SS2d', axes(1:2), Time, & + 'Column integrated total snow specific humidity', & + 'kg/m2/sec', missing_value=missing_value) + diag_id%SNS2d = register_diag_field ( mod_name, & + 'SNS2d', axes(1:2), Time, & + 'Column integrated total snow particle number specific humidity', & + '#/m2/sec', missing_value=missing_value) + diag_id%srfrain_accrs_col= register_diag_field ( mod_name, & 'srfrain_accrs_col', axes(1:2), Time, & 'Column integrated rain water sink from collection by snow', & @@ -2534,7 +2971,11 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & diag_id%qni_fill_col = register_diag_field (mod_name, & 'qni_fill_col', axes(1:2), Time, & 'Column integrated ice particle number tendency from filler',& - '#/m2/sec', missing_value=missing_value) + '#/m2/sec', missing_value=missing_value) + diag_id%qni_tiny_col = register_diag_field (mod_name, & + 'qni_tiny_col', axes(1:2), Time, & + 'Column integrated ice particle number tendency from microphysics substep filler',& + '#/m2/sec', missing_value=missing_value) diag_id%qni_nnuccd_col = register_diag_field (mod_name, & 'qni_nnuccd_col', axes(1:2), Time, & 'Column integrated ice particle number tendency from & @@ -2547,6 +2988,14 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'qni_nerosi_col', axes(1:2), Time, & 'Column integrated ice particle number tendency from & &erosion', '#/m2/sec', missing_value=missing_value) + diag_id%qni_auto_col = register_diag_field (mod_name, & + 'qni_auto_col', axes(1:2), Time, & + 'Column integrated ice particle number tendency from & + &autoconversion', '#/m2/sec', missing_value=missing_value) + diag_id%qni_accr_col = register_diag_field (mod_name, & + 'qni_accr_col', axes(1:2), Time, & + 'Column integrated ice particle number tendency from & + &accretion by snow', '#/m2/sec', missing_value=missing_value) diag_id%qni_nprci_col = register_diag_field (mod_name, & 'qni_nprci_col', axes(1:2), Time, & 'Column integrated ice particle number tendency from & @@ -2588,7 +3037,11 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'qni_ihom_col', axes(1:2), Time, & 'Column integrated ice particle number tendency from & &homogeneous freezing', '#/m2/sec', & - missing_value=missing_value) + missing_value=missing_value) + diag_id%qni_rain2ice_col = register_diag_field (mod_name, & + 'qni_rain2ice_col', axes(1:2), Time, & + 'Column integrated ice particle number tendency from & + &converting rain to ice', '#/m2/sec', missing_value=missing_value) diag_id%qni_destr_col = register_diag_field (mod_name, & 'qni_destr_col', axes(1:2), Time, & 'Column integrated ice particle number tendency from cloud & @@ -2606,6 +3059,144 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & 'Column integrated ice particle number tendency from HM & &ice multiplication', '#/m2/sec', missing_value=missing_value) +!------------------------------------------------------------------------ +! 18) variables associated with prognostic precipitation: +!------------------------------------------------------------------------ + diag_id%rain_inst_col= register_diag_field ( mod_name, & + 'rain_inst_col', axes(1:2), Time, & + 'Column integrated rain water instantaneous freezing/melting ', & + 'kg/m2/sec', missing_value=missing_value) + + diag_id%rain_sedi_col= register_diag_field ( mod_name, & + 'rain_sedi_col', axes(1:2), Time, & + 'Column integrated rain water sedimentation ', & + 'kg/m2/sec', missing_value=missing_value) + + diag_id%rain_num_inst_col= register_diag_field ( mod_name, & + 'rain_num_inst_col', axes(1:2), Time, & + 'Column integrated rain number instantaneous freezing/melting ', & + '#/m2/sec', missing_value=missing_value) + + diag_id%rain_num_sedi_col= register_diag_field ( mod_name, & + 'rain_num_sedi_col', axes(1:2), Time, & + 'Column integrated rain number sedimentation ', & + '#/m2/sec', missing_value=missing_value) + + diag_id%rain_num_adj_col= register_diag_field ( mod_name, & + 'rain_num_adj_col', axes(1:2), Time, & + 'Column integrated rain number changes due to rain size adjustment ', & + '#/m2/sec', missing_value=missing_value) + + diag_id%rain_num2snow_col= register_diag_field ( mod_name, & + 'rain_num2snow_col', axes(1:2), Time, & + 'Column integrated rain number changes due to rain freezing to snow', & + '#/m2/sec', missing_value=missing_value) + diag_id%rain_num_evap_col= register_diag_field ( mod_name, & + 'rain_num_evap_col', axes(1:2), Time, & + 'Column integrated rain number changes due to rain evaporation', & + '#/m2/sec', missing_value=missing_value) + + diag_id%rain_num_freez_col= register_diag_field ( mod_name, & + 'rain_num_freez_col', axes(1:2), Time, & + 'Column integrated rain number changes due to rain homogeneous freezing', & + '#/m2/sec', missing_value=missing_value) + diag_id%rain_num_selfcoll_col= register_diag_field ( mod_name, & + 'rain_num_selfcoll_col', axes(1:2), Time, & + 'Column integrated rain number changes due to rain number self-collection', & + '#/m2/sec', missing_value=missing_value) + + + + diag_id%snow_inst_col= register_diag_field ( mod_name, & + 'snow_inst_col', axes(1:2), Time, & + 'Column integrated snow instantaneous freezing/melting ', & + 'kg/m2/sec', missing_value=missing_value) + + diag_id%snow_sedi_col= register_diag_field ( mod_name, & + 'snow_sedi_col', axes(1:2), Time, & + 'Column integrated snow sedimentation ', & + 'kg/m2/sec', missing_value=missing_value) + + diag_id%snow_num_inst_col= register_diag_field ( mod_name, & + 'snow_num_inst_col', axes(1:2), Time, & + 'Column integrated snow number instantaneous freezing/melting ', & + '#/m2/sec', missing_value=missing_value) + + diag_id%snow_num_sedi_col= register_diag_field ( mod_name, & + 'snow_num_sedi_col', axes(1:2), Time, & + 'Column integrated snow number sedimentation ', & + '#/m2/sec', missing_value=missing_value) + diag_id%snow_num_melt_col= register_diag_field ( mod_name, & + 'snow_num_melt_col', axes(1:2), Time, & + 'Column integrated snow number melting ', & + '#/m2/sec', missing_value=missing_value) + + diag_id%snow_num_adj_col= register_diag_field ( mod_name, & + 'snow_num_adj_col', axes(1:2), Time, & + 'Column integrated snow number changes due to snow size adjustment ', & + '#/m2/sec', missing_value=missing_value) + + diag_id%qr_fill_col = register_diag_field (mod_name, & + 'qr_fill_col', axes(1:2), Time, & + 'Column integrated pre-microphysics rain filler', & + 'kg/m2/sec', missing_value=missing_value) + + diag_id%qnr_fill_col = register_diag_field (mod_name, & + 'qnr_fill_col', axes(1:2), Time, & + 'Column integrated pre-microphysics rain drop number filler', & + '#/m2/sec', missing_value=missing_value) + + diag_id%qr_tiny_col = register_diag_field (mod_name, & + 'qr_tiny_col', axes(1:2), Time, & + 'Column integrated in-microphysics substep rain filler', & + 'kg/m2/sec', missing_value=missing_value) + + diag_id%qnr_tiny_col = register_diag_field (mod_name, & + 'qnr_tiny_col', axes(1:2), Time, & + 'Column integrated in-microphysics substep rain drop number filler', & + '#/m2/sec', missing_value=missing_value) + + diag_id%qs_fill_col = register_diag_field (mod_name, & + 'qs_fill_col', axes(1:2), Time, & + 'Column integrated pre-microphysics snow filler', & + 'kg/m2/sec', missing_value=missing_value) + + diag_id%qns_fill_col = register_diag_field (mod_name, & + 'qns_fill_col', axes(1:2), Time, & + 'Column integrated pre-microphysics snow particle number filler', & + '#/m2/sec', missing_value=missing_value) + + diag_id%qs_tiny_col = register_diag_field (mod_name, & + 'qs_tiny_col', axes(1:2), Time, & + 'Column integrated in-microphysics substep snow filler', & + 'kg/m2/sec', missing_value=missing_value) + + diag_id%qns_tiny_col = register_diag_field (mod_name, & + 'qns_tiny_col', axes(1:2), Time, & + 'Column integrated in-microphysics substep snow particle number filler', & + '#/m2/sec', missing_value=missing_value) + + diag_id%qr_destr_col = register_diag_field (mod_name, & + 'qr_destr_col', axes(1:2), Time, & + 'Column integrated after microphysics rain destruction', & + 'kg/m2/sec', missing_value=missing_value) + + diag_id%qnr_destr_col = register_diag_field (mod_name, & + 'qnr_destr_col', axes(1:2), Time, & + 'Column integrated after microphysics rain drop number destruction', & + '#/m2/sec', missing_value=missing_value) + + diag_id%qs_destr_col = register_diag_field (mod_name, & + 'qs_destr_col', axes(1:2), Time, & + 'Column integrated after microphysics snow destruction', & + 'kg/m2/sec', missing_value=missing_value) + + diag_id%qns_destr_col = register_diag_field (mod_name, & + 'qns_destr_col', axes(1:2), Time, & + 'Column integrated after microphysics snow particle number destruction', & + '#/m2/sec', missing_value=missing_value) + + !------------------------------------------------------------------------ ! determine the number of activated diagnostic variables on both ! full and half levels in the vertical. thesde values will be used @@ -2848,6 +3439,11 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & diag_pt%qldt_fill = n_diag_4d n_diag_4d = n_diag_4d + 1 end if + if (diag_id%qldt_tiny + diag_id%ql_tiny_col > 0) then + diag_pt%qldt_tiny = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + if (diag_id%qldt_berg + diag_id%ql_berg_col > 0) then diag_pt%qldt_berg = n_diag_4d n_diag_4d = n_diag_4d + 1 @@ -2901,6 +3497,10 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & diag_pt%qndt_fill = n_diag_4d n_diag_4d = n_diag_4d + 1 end if + if (diag_id%qndt_tiny + diag_id%qn_tiny_col > 0) then + diag_pt%qndt_tiny = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if if (diag_id%qndt_destr + diag_id%qn_destr_col > 0) then diag_pt%qndt_destr = n_diag_4d n_diag_4d = n_diag_4d + 1 @@ -2978,6 +3578,11 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & diag_pt%qnidt_fill = n_diag_4d n_diag_4d = n_diag_4d + 1 end if + if (diag_id%qnidt_tiny + diag_id%qni_tiny_col > 0) then + diag_pt%qnidt_tiny = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + if (diag_id%qnidt_nnuccd + diag_id%qni_nnuccd_col > 0) then diag_pt%qnidt_nnuccd = n_diag_4d n_diag_4d = n_diag_4d + 1 @@ -2990,6 +3595,14 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & diag_pt%qnidt_nerosi = n_diag_4d n_diag_4d = n_diag_4d + 1 end if + if (diag_id%qnidt_auto + diag_id%qni_auto_col > 0) then + diag_pt%qnidt_auto = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + if (diag_id%qnidt_accr + diag_id%qni_accr_col > 0) then + diag_pt%qnidt_accr = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if if (diag_id%qnidt_nprci + diag_id%qni_nprci_col > 0) then diag_pt%qnidt_nprci = n_diag_4d n_diag_4d = n_diag_4d + 1 @@ -3030,6 +3643,10 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & diag_pt%qnidt_ihom = n_diag_4d n_diag_4d = n_diag_4d + 1 end if + if (diag_id%qnidt_rain2ice + diag_id%qni_rain2ice_col > 0) then + diag_pt%qnidt_rain2ice = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if if (diag_id%qnidt_destr + diag_id%qni_destr_col > 0) then diag_pt%qnidt_destr = n_diag_4d n_diag_4d = n_diag_4d + 1 @@ -3170,6 +3787,10 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & diag_pt%qidt_fill = n_diag_4d n_diag_4d = n_diag_4d + 1 end if + if (diag_id%qidt_tiny + diag_id%qi_tiny_col > 0) then + diag_pt%qidt_tiny = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if if (diag_id%qidt_auto + diag_id%qi_auto_col > 0) then diag_pt%qidt_auto = n_diag_4d n_diag_4d = n_diag_4d + 1 @@ -3182,6 +3803,10 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & diag_pt%qidt_accrs = n_diag_4d n_diag_4d = n_diag_4d + 1 end if + if (diag_id%qidt_rain2ice + diag_id%qi_rain2ice_col > 0) then + diag_pt%qidt_rain2ice = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if !----------------------------------------------------------------------- ! 15) variables associated with cloud area time tendency: @@ -3255,6 +3880,25 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & diag_pt%SNI3d = n_diag_4d n_diag_4d = n_diag_4d + 1 end if + + if (diag_id%SR3d + diag_id%SR2d > 0) then + diag_pt%SR3d = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + if (diag_id%SNR3d + diag_id%SNR2d > 0) then + diag_pt%SNR3d = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + if (diag_id%SS3d + diag_id%SS2d > 0) then + diag_pt%SS3d = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + if (diag_id%SNS3d + diag_id%SNS2d > 0) then + diag_pt%SNS3d = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qndt_contact_frz + diag_id%qn_contact_frz_col > 0) then diag_pt%qndt_contact_frz = n_diag_4d n_diag_4d = n_diag_4d + 1 @@ -3418,6 +4062,144 @@ subroutine diag_field_init (axes, Time, diag_id, diag_pt, n_diag_4d, & n_diag_4d = n_diag_4d + 1 end if +!------------------------------------------------------------------------ +! 18) variables associated with prognostic precipitation +!------------------------------------------------------------------------ + if (diag_id%qrdt_fill + diag_id%qr_fill_col > 0) then + diag_pt%qrdt_fill = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qnrdt_fill + diag_id%qnr_fill_col > 0) then + diag_pt%qnrdt_fill = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qrdt_tiny + diag_id%qr_tiny_col > 0) then + diag_pt%qrdt_tiny = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qnrdt_tiny + diag_id%qnr_tiny_col > 0) then + diag_pt%qnrdt_tiny = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qsdt_fill + diag_id%qs_fill_col > 0) then + diag_pt%qsdt_fill = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qnsdt_fill + diag_id%qns_fill_col > 0) then + diag_pt%qnsdt_fill = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qsdt_tiny + diag_id%qs_tiny_col > 0) then + diag_pt%qsdt_tiny = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qnsdt_tiny + diag_id%qns_tiny_col > 0) then + diag_pt%qnsdt_tiny = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qrdt_destr + diag_id%qr_destr_col > 0) then + diag_pt%qrdt_destr = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qnrdt_destr + diag_id%qnr_destr_col > 0) then + diag_pt%qnrdt_destr = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qsdt_destr + diag_id%qs_destr_col > 0) then + diag_pt%qsdt_destr = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%qnsdt_destr + diag_id%qns_destr_col > 0) then + diag_pt%qnsdt_destr = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%rain_inst + diag_id%rain_inst_col > 0) then + diag_pt%rain_inst = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%rain_sedi + diag_id%rain_sedi_col > 0) then + diag_pt%rain_sedi = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%rain_num_inst + diag_id%rain_num_inst_col > 0) then + diag_pt%rain_num_inst = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%rain_num_sedi + diag_id%rain_num_sedi_col > 0) then + diag_pt%rain_num_sedi = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%rain_num_adj + diag_id%rain_num_adj_col > 0) then + diag_pt%rain_num_adj = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%rain_num2snow + diag_id%rain_num2snow_col > 0) then + diag_pt%rain_num2snow = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%rain_num_evap + diag_id%rain_num_evap_col > 0) then + diag_pt%rain_num_evap = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%rain_num_freez + diag_id%rain_num_freez_col > 0) then + diag_pt%rain_num_freez = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%rain_num_selfcoll + diag_id%rain_num_selfcoll_col > 0) then + diag_pt%rain_num_selfcoll = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + + if (diag_id%snow_inst + diag_id%snow_inst_col > 0) then + diag_pt%snow_inst = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%snow_sedi + diag_id%snow_sedi_col > 0) then + diag_pt%snow_sedi = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%snow_num_inst + diag_id%snow_num_inst_col > 0) then + diag_pt%snow_num_inst = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%snow_num_sedi + diag_id%snow_num_sedi_col > 0) then + diag_pt%snow_num_sedi = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%snow_num_melt + diag_id%snow_num_melt_col > 0) then + diag_pt%snow_num_melt = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if + + if (diag_id%snow_num_adj + diag_id%snow_num_adj_col > 0) then + diag_pt%snow_num_adj = n_diag_4d + n_diag_4d = n_diag_4d + 1 + end if !---------------------------------------------------------------------- diff --git a/atmos_param/lscloud_driver/lscloud_types.F90 b/atmos_param/lscloud_driver/lscloud_types.F90 index 2e6d60d9..1582654d 100644 --- a/atmos_param/lscloud_driver/lscloud_types.F90 +++ b/atmos_param/lscloud_driver/lscloud_types.F90 @@ -42,35 +42,49 @@ module lscloud_types_mod ! cloud liquid variables integer :: SL3d, qldt_cond, qldt_evap, qldt_eros, qldt_berg, qldt_freez,& - liq_adj, qldt_rime, qldt_accr, qldt_auto, qldt_fill, & + liq_adj, qldt_rime, qldt_accr, qldt_auto, qldt_fill, qldt_tiny, & qldt_destr, qldt_freez2, qldt_sedi, qldt_accrs, qldt_bergs, & qldt_HM_splinter, SL_imb integer :: SL2d, ql_cond_col, ql_evap_col, ql_eros_col, ql_berg_col, & ql_freez_col, liq_adj_col, ql_rime_col, ql_accr_col, & - ql_auto_col, ql_fill_col, ql_destr_col, ql_freez2_col, & + ql_auto_col, ql_fill_col, ql_tiny_col, ql_destr_col, ql_freez2_col, & ql_sedi_col, ql_accrs_col, ql_bergs_col, ql_HM_splinter_col, & SL_imb_col ! cloud ice variables integer :: SI3d, qidt_dep, qidt_subl, qidt_fall, qidt_eros, qidt_melt, & - qidt_melt2, qidt_fill, qidt_destr, qidt_qvdep, qidt_auto, & - qidt_accr, qidt_accrs, ice_adj, SI_imb + qidt_melt2, qidt_fill, qidt_tiny, qidt_destr, qidt_qvdep, qidt_auto, & + qidt_accr, qidt_accrs, ice_adj, qidt_rain2ice, SI_imb integer :: SI2d, qi_dep_col, qi_subl_col, qi_fall_col, qi_eros_col, & - qi_melt_col, qi_melt2_col, qi_fill_col, qi_destr_col, & + qi_melt_col, qi_melt2_col, qi_fill_col, qi_tiny_col, qi_destr_col, & qi_qvdep_col, qi_auto_col, qi_accr_col, qi_accrs_col, & - ice_adj_col, SI_imb_col + ice_adj_col, qi_rain2ice_col, SI_imb_col + +! rain variables + integer :: qrdt_fill, qr_fill_col, qrdt_destr, qr_destr_col, qrdt_tiny, qr_tiny_col + +! snow variables + integer :: qsdt_fill, qs_fill_col, qsdt_destr, qs_destr_col, qsdt_tiny, qs_tiny_col + +! rain number variables + integer :: qnrdt_fill, qnr_fill_col, qnrdt_destr, qnr_destr_col, qnrdt_tiny, qnr_tiny_col + +! snow number variables + integer :: qnsdt_fill, qns_fill_col, qnsdt_destr, qns_destr_col, qnsdt_tiny, qns_tiny_col + + integer :: SR3d, SR2d, SNR3d, SNR2d, SS3d, SS2d, SNS3d, SNS2d ! cloud droplet variables integer :: droplets_col250, gb_droplets_col, potential_droplets, & droplets, droplets_wtd, ql_wt, droplets_col, rvolume - integer :: SN3d, qndt_cond , qndt_evap, qndt_fill, qndt_berg, qndt_rime, & !h1g, 2014-07-24 + integer :: SN3d, qndt_cond , qndt_evap, qndt_fill, qndt_tiny, qndt_berg, qndt_rime, & !h1g, 2014-07-24 qndt_destr, qndt_super, qndt_freez, qndt_sacws, qndt_sacws_o, & qndt_eros, qndt_pra, qndt_auto, qndt_nucclim, qndt_sedi, & qndt_melt, qndt_ihom, qndt_size_adj, qndt_fill2, & qndt_contact_frz, qndt_cleanup, qndt_cleanup2, SN_imb - integer :: SN2d, qn_cond_col, qn_evap_col, qn_fill_col, qn_berg_col, qn_rime_col, & !h1g, 2014-07-24 + integer :: SN2d, qn_cond_col, qn_evap_col, qn_fill_col, qn_tiny_col, qn_berg_col, qn_rime_col, & !h1g, 2014-07-24 qn_destr_col, qn_super_col, qn_freez_col, qn_sacws_col, & qn_sacws_o_col, qn_eros_col, qn_pra_col, qn_auto_col, & qn_nucclim_col, qn_sedi_col, qn_melt_col, qn_ihom_col, & @@ -80,17 +94,17 @@ module lscloud_types_mod ! cloud ice particle variables integer :: nice, nice_col, gb_nice_col, potential_crystals - integer :: SNi3d, qnidt_fill, qnidt_nnuccd, qnidt_nsubi, & - qnidt_nerosi, qnidt_nprci, qnidt_nprai, & + integer :: SNi3d, qnidt_fill, qnidt_tiny, qnidt_nnuccd, qnidt_nsubi, & + qnidt_nerosi, qnidt_auto, qnidt_accr, qnidt_nprci, qnidt_nprai, & qnidt_nucclim1, qnidt_nucclim2, qnidt_sedi, & qnidt_melt, qnidt_size_adj, qnidt_fill2, & - qnidt_super, qnidt_ihom, qnidt_destr, & + qnidt_super, qnidt_ihom, qnidt_destr, qnidt_rain2ice, & qnidt_cleanup, qnidt_cleanup2, qnidt_nsacwi, SNi_imb - integer :: SNi2d, qni_fill_col, qni_nnuccd_col, qni_nsubi_col, & - qni_nerosi_col, qni_nprci_col, qni_nprai_col, & + integer :: SNi2d, qni_fill_col, qni_tiny_col, qni_nnuccd_col, qni_nsubi_col, & + qni_nerosi_col, qni_auto_col, qni_accr_col, qni_nprci_col, qni_nprai_col, & qni_nucclim1_col, qni_nucclim2_col, qni_sedi_col, & qni_melt_col, qni_size_adj_col, qni_fill2_col, & - qni_super_col, qni_ihom_col, qni_destr_col, & + qni_super_col, qni_ihom_col, qni_destr_col, qni_rain2ice_col, & qni_cleanup_col, qni_cleanup2_col, & qni_nsacwi_col, SNi_imb_col @@ -105,17 +119,31 @@ module lscloud_types_mod integer :: rain3d, qrout, rain_clr, rain_cld, a_rain_clr, a_rain_cld, & rain_evap, rain_freeze, srfrain_accrs, srfrain_freez, & - srfrain_evap, rain_evap_col, rain_freeze_col, & + srfrain_evap, rain_inst, rain_sedi, & + rain_evap_col, rain_freeze_col, & srfrain_accrs_col, srfrain_freez_col, srfrain_evap_col, & - rain_mass_conv, rain_imb, cld_liq_imb, & + rain_inst_col, rain_sedi_col, & + rain_mass_conv, rain_imb, rain_imb_col, cld_liq_imb, & cld_liq_imb_col, neg_rain, qrout_col +! rain number diagnostics + integer :: rain_num_inst, rain_num_sedi, rain_num_adj, rain_num2snow, & + rain_num_evap, rain_num_freez, rain_num_selfcoll, & + rain_num_inst_col, rain_num_sedi_col, rain_num_adj_col, rain_num2snow_col, & + rain_num_evap_col, rain_num_freez_col,rain_num_selfcoll_col + ! snow diagnostics integer :: snow3d, qsout, snow_clr, snow_cld, a_snow_clr, a_snow_cld, & - snow_melt, snow_melt_col, snow_mass_conv, sedi_ice, snow_imb, & - cld_ice_imb, cld_ice_imb_col, neg_snow, qsout_col - + snow_melt, snow_inst, snow_sedi, & + snow_melt_col, snow_mass_conv, sedi_ice, snow_imb, & + snow_inst_col, snow_sedi_col, & + snow_imb_col, cld_ice_imb, cld_ice_imb_col, neg_snow, qsout_col + +! snow number diagnostics + integer :: snow_num_inst, snow_num_sedi, snow_num_melt, snow_num_adj, & + snow_num_inst_col, snow_num_sedi_col, snow_num_melt_col, snow_num_adj_col + ! total precip diagnostics @@ -128,12 +156,12 @@ module lscloud_types_mod ! vapor diagnostics - integer :: SQ3d, qdt_liquid_init, qdt_ice_init, qdt_rain_evap, & + integer :: SQ3d, qdt_liquid_init, qdt_ice_init, qdt_tiny, qdt_rain_evap, & qdt_cond, qdt_deposition, qdt_eros_l, qdt_eros_i, & qdt_qv_on_qi, qdt_sedi_ice2vapor, qdt_sedi_liquid2vapor, & qdt_super_sat_rm, qdt_destr, qdt_cleanup_liquid, & qdt_cleanup_ice, qdt_snow_sublim, qdt_snow2vapor, SQ_imb - integer :: SQ2d, q_liquid_init_col, q_ice_init_col, q_rain_evap_col, & + integer :: SQ2d, q_liquid_init_col, q_ice_init_col, q_tiny_col, q_rain_evap_col, & q_cond_col, q_deposition_col, q_eros_l_col, q_eros_i_col, & q_qv_on_qi_col, q_sedi_ice2vapor_col, q_sedi_liquid2vapor_col,& q_super_sat_rm_col, q_destr_col, q_cleanup_liquid_col, & @@ -166,21 +194,36 @@ module lscloud_types_mod ! cloud liquid variables integer :: SL3d, qldt_cond, qldt_evap, qldt_eros, qldt_berg, qldt_freez,& - liq_adj, qldt_rime, qldt_accr, qldt_auto, qldt_fill, & + liq_adj, qldt_rime, qldt_accr, qldt_auto, qldt_fill, qldt_tiny, & qldt_destr, qldt_freez2, qldt_sedi, qldt_accrs, qldt_bergs, & qldt_HM_splinter, SL_imb ! cloud ice variables integer :: SI3d, qidt_dep, qidt_subl, qidt_fall, qidt_eros, qidt_melt, & - qidt_melt2, qidt_fill, qidt_destr, qidt_qvdep, qidt_auto, & - qidt_accr, qidt_accrs, ice_adj, SI_imb + qidt_melt2, qidt_fill, qidt_tiny, qidt_destr, qidt_qvdep, qidt_auto, & + qidt_accr, qidt_accrs, ice_adj, qidt_rain2ice, SI_imb + +! rain variables + integer :: qrdt_fill, qrdt_destr, qrdt_tiny + +! snow variables + integer :: qsdt_fill, qsdt_destr, qsdt_tiny + +! rain number variables + integer :: qnrdt_fill, qnrdt_destr, qnrdt_tiny + +! snow number variables + integer :: qnsdt_fill, qnsdt_destr, qnsdt_tiny + + integer :: SR3d, SR2d, SNR3d, SNR2d, SS3d, SS2d, SNS3d, SNS2d + ! cloud droplet variables integer :: droplets_col250, gb_droplets_col, potential_droplets, & droplets, droplets_wtd, ql_wt, droplets_col, rvolume - integer :: SN3d, qndt_cond , qndt_evap, qndt_fill, qndt_berg, qndt_rime, & !h1g, 2014-07-24 + integer :: SN3d, qndt_cond , qndt_evap, qndt_fill, qndt_tiny, qndt_berg, qndt_rime, & !h1g, 2014-07-24 qndt_destr, qndt_super, qndt_freez, qndt_sacws, qndt_sacws_o, & qndt_eros, qndt_pra, qndt_auto, qndt_nucclim, qndt_sedi, & qndt_melt, qndt_ihom, qndt_size_adj, qndt_fill2, & @@ -189,11 +232,11 @@ module lscloud_types_mod ! cloud ice particle variables integer :: nice, nice_col, gb_nice_col, potential_crystals - integer :: SNi3d, qnidt_fill, qnidt_nnuccd, qnidt_nsubi, & - qnidt_nerosi, qnidt_nprci, qnidt_nprai, & + integer :: SNi3d, qnidt_fill, qnidt_tiny, qnidt_nnuccd, qnidt_nsubi, & + qnidt_nerosi, qnidt_auto, qnidt_accr, qnidt_nprci, qnidt_nprai, & qnidt_nucclim1, qnidt_nucclim2, qnidt_sedi, & qnidt_melt, qnidt_size_adj, qnidt_fill2, & - qnidt_super, qnidt_ihom, qnidt_destr, & + qnidt_super, qnidt_ihom, qnidt_destr, qnidt_rain2ice, & qnidt_cleanup, qnidt_cleanup2, qnidt_nsacwi, SNi_imb ! aerosol diagnostics @@ -204,17 +247,26 @@ module lscloud_types_mod ndust4, ndust5, dust_berg_flag, subgrid_w_variance ! rain diagnostics - integer :: rain3d, qrout, rain_clr, rain_cld, a_rain_clr, a_rain_cld, & rain_evap, rain_freeze, srfrain_accrs, srfrain_freez, & + rain_inst, rain_sedi, & srfrain_evap, rain_mass_conv, rain_imb, cld_liq_imb, neg_rain -! snow diagnostics +! rain number diagnostics + integer :: rain_num_inst, rain_num_sedi, rain_num_adj, rain_num2snow, & + rain_num_evap, rain_num_freez, rain_num_selfcoll +! snow diagnostics integer :: snow3d, qsout, snow_clr, snow_cld, a_snow_clr, a_snow_cld, & + snow_inst, snow_sedi,& snow_melt, snow_mass_conv, sedi_ice, snow_imb, cld_ice_imb, & neg_snow +! snow number diagnostics + integer :: snow_num_inst, snow_num_sedi, snow_num_melt, snow_num_adj + + + ! total precip diagnostics integer :: a_precip_cld, a_precip_clr, sedi_sfc @@ -225,7 +277,7 @@ module lscloud_types_mod ! vapor diagnostics - integer :: SQ3d, qdt_liquid_init, qdt_ice_init, qdt_rain_evap, & + integer :: SQ3d, qdt_liquid_init, qdt_ice_init, qdt_tiny, qdt_rain_evap, & qdt_cond, qdt_deposition, qdt_eros_l, qdt_eros_i, & qdt_qv_on_qi, qdt_sedi_ice2vapor, qdt_sedi_liquid2vapor, & qdt_super_sat_rm, qdt_destr, qdt_cleanup_liquid, & @@ -375,25 +427,44 @@ module lscloud_types_mod ! intermediate qi real, dimension(:,:,:), pointer :: & ql_upd =>NULL(), & + qr_upd =>NULL(), & qi_upd =>NULL(), & + qs_upd =>NULL(), & + qg_upd =>NULL(), & qa_upd =>NULL(), & qn_upd =>NULL(), & qni_upd =>NULL(), & + qnr_upd =>NULL(), & + qns_upd =>NULL(), & ql_mean =>NULL(), & + qr_mean =>NULL(), & qi_mean =>NULL(), & + qs_mean =>NULL(), & + qg_mean =>NULL(), & qa_mean =>NULL(), & qn_mean =>NULL(), & qni_mean =>NULL(), & + qnr_mean =>NULL(), & + qns_mean =>NULL(), & ql_in =>NULL(), & + qr_in =>NULL(), & qi_in =>NULL(), & + qs_in =>NULL(), & + qg_in =>NULL(), & qa_in =>NULL(), & qn_in =>NULL(), & qni_in =>NULL(), & + qnr_in =>NULL(), & + qns_in =>NULL(), & SL_out =>NULL(), & SI_out =>NULL(), & SA_out =>NULL(), & SN_out =>NULL(), & SNi_out =>NULL(), & + SR_out =>NULL(), & + SS_out =>NULL(), & + SNR_out =>NULL(), & + SNS_out =>NULL(), & SA_0 =>NULL(), & qa_upd_0 =>NULL(), & relvarn =>NULL(), & @@ -472,6 +543,7 @@ module lscloud_types_mod do_mg_microphys, & do_mg_ncar_microphys, & do_ncar_microphys, & + do_ncar_MG2, & do_lin_cld_microphys, & tiedtke_macrophysics, & dqa_activation, & diff --git a/atmos_param/macrophysics/tiedtke_macro.F90 b/atmos_param/macrophysics/tiedtke_macro.F90 index 2ca9c6b7..9f6f71ad 100644 --- a/atmos_param/macrophysics/tiedtke_macro.F90 +++ b/atmos_param/macrophysics/tiedtke_macro.F90 @@ -770,6 +770,9 @@ subroutine tiedtke_macro_diagnostics ( & if (diag_id%dcond > 0 ) & diag_4d(:,:,:,diag_pt%dcond) = Cloud_processes%dcond_ls(:,:,:) +!--> h1g, this is only for partial activation +!--> (i.e., dqa_activation = true or aerosol_activation_scheme = dqa + if ( .not. total_activation ) then do k=1,kdim do j=1,jdim do i=1,idim @@ -782,7 +785,7 @@ subroutine tiedtke_macro_diagnostics ( & end do end do end do - + endif !----------------------------------------------------------------------- end subroutine tiedtke_macro_diagnostics diff --git a/atmos_param/microphysics/ls_cloud_microphysics.F90 b/atmos_param/microphysics/ls_cloud_microphysics.F90 index b1db208e..2acc4a52 100644 --- a/atmos_param/microphysics/ls_cloud_microphysics.F90 +++ b/atmos_param/microphysics/ls_cloud_microphysics.F90 @@ -10,6 +10,7 @@ module ls_cloud_microphysics_mod ! MG microphysics (as developed by M. Salzmann) ! MG-NCAR microphysics (an early version of NCAR microphysics) ! NCAR microphysics version 1.5 (became available in 2012) +! NCAR microphysics version 2.0 (became available? ) ! !----------------------------------------------------------------------- @@ -70,6 +71,9 @@ module ls_cloud_microphysics_mod use micro_mg_mod, only: micro_mg_init, micro_mg_get_cols,& micro_mg_tend +use micro_mg2_mod, only: micro_mg2_init, micro_mg2_get_cols,& + micro_mg2_tend + implicit none private @@ -108,7 +112,7 @@ module ls_cloud_microphysics_mod ! model ice particle number ? logical :: use_Cooper = .false. ! use Cooper formula when overriding ! model ice particle number ? -integer, dimension(6) :: init_date = (/ 1980, 1, 1, 0, 0, 0 /) +integer, dimension(6) :: init_date = (/ 1, 1, 1, 0, 0, 0 /) ! date to use as base for ! defining microphysics start time real :: micro_begin_sec = 0.0 ! begin microphysics this many @@ -117,17 +121,21 @@ module ls_cloud_microphysics_mod real :: min_precip_needing_adjustment = 0.0 real :: lowest_allowed_precip = 0.0 logical :: use_ndust = .false. +real :: accretion_scale = 1.0 +real :: liq_num_eros_fac = 1.0 +real :: ice_num_eros_fac = 1.0 +logical :: do_cleanup = .true. namelist / ls_cloud_microphysics_nml / & lin_microphys_top_press, mass_cons, & override_liq_num, override_ice_num, & use_Meyers, use_Cooper, init_date, & micro_begin_sec, top_lev, & min_precip_needing_adjustment, & - lowest_allowed_precip, use_ndust - - + lowest_allowed_precip, use_ndust, accretion_scale, & + do_cleanup, liq_num_eros_fac, ice_num_eros_fac !h1g, 2020-06-22 + !-------------------- clock definitions -------------------------------- integer :: rk_micro_clock, lin_micro_clock, ncar_micro_clock @@ -144,10 +152,10 @@ module ls_cloud_microphysics_mod logical :: doing_prog_clouds real :: dtcloud, inv_dtcloud logical :: do_rk_microphys, do_mg_microphys, do_mg_ncar_microphys, & - do_ncar_microphys + do_ncar_microphys, do_ncar_MG2 logical :: tiedtke_macrophysics logical :: dqa_activation, total_activation -integer :: nsphum, nql, nqi, nqa, nqn, nqni, nqr, nqs, nqg +integer :: nsphum, nql, nqi, nqa, nqn, nqni, nqr, nqs, nqg, nqnr, nqns !-------------------------------------------------------------------- ! other module variables @@ -218,6 +226,9 @@ subroutine ls_cloud_microphysics_init ( & do_mg_microphys = Constants_lsc%do_mg_microphys do_mg_ncar_microphys = Constants_lsc%do_mg_ncar_microphys do_ncar_microphys = Constants_lsc%do_ncar_microphys + + do_ncar_MG2 = Constants_lsc%do_ncar_MG2 + tiedtke_macrophysics = Constants_lsc%tiedtke_macrophysics dqa_activation = Constants_lsc%dqa_activation total_activation = Constants_lsc%total_activation @@ -230,6 +241,9 @@ subroutine ls_cloud_microphysics_init ( & nqr = Physics_control%nqr nqs = Physics_control%nqs + nqnr = Physics_control%nqnr + nqns = Physics_control%nqns + !------------------------------------------------------------------------ ! define clocks for large-scale cloud schemes initialization (local ! variables) and for the prognostic loop clocks (module variables). @@ -254,6 +268,10 @@ subroutine ls_cloud_microphysics_init ( & ncar_micro_init_clock = mpp_clock_id( & ' Ls_cld_micro: ncar_micro:Initialization' , & grain=CLOCK_MODULE_DRIVER) + else if (do_ncar_MG2) then + ncar_micro_init_clock = mpp_clock_id( & + ' Ls_cld_micro: ncar_MG2:Initialization' , & + grain=CLOCK_MODULE_DRIVER) endif if (do_rk_microphys) then @@ -276,6 +294,10 @@ subroutine ls_cloud_microphysics_init ( & ncar_micro_clock = mpp_clock_id( & ' Ls_cld_micro: ncar_micro' , & grain=CLOCK_MODULE_DRIVER ) + else if (do_ncar_MG2) then + ncar_micro_clock = mpp_clock_id( & + ' Ls_cld_micro: ncar_MG2' , & + grain=CLOCK_MODULE_DRIVER ) endif !------------------------------------------------------------------------- @@ -387,6 +409,20 @@ subroutine ls_cloud_microphysics_init ( & endif call mpp_clock_end (ncar_micro_init_clock) +!----------------------------------------------------------------------- +! ncar microphysics (ncar v2.0) +!----------------------------------------------------------------------- + else if (do_ncar_MG2) then + call mpp_clock_begin (ncar_micro_init_clock) + call micro_mg2_init (r8, GRAV, RDGAS, RVGAS, CP_AIR, TFREEZE, & + HLV, HLF, Nml_lsc%do_ice_nucl_wpdf, & + errstring, Exch_ctrl) + if (trim(errstring) /= '') then + call error_mesg ('ls_cloud_microphysics/micro_mg2_init', & + errstring, FATAL) + endif + call mpp_clock_end (ncar_micro_init_clock) + !----------------------------------------------------------------------- ! no valid microphys scheme chosen !----------------------------------------------------------------------- @@ -446,7 +482,7 @@ end subroutine ls_cloud_microphysics_time_vary !######################################################################## subroutine ls_cloud_microphysics ( & - is, ie, js, je, Time, dt, Input_mp, Output_mp, C2ls_mp,& + is, ie, js, je, Time, dt, lon, lat, Input_mp, Output_mp, C2ls_mp,& Tend_mp, Lsdiag_mp, Lsdiag_mp_control, Atmos_state, & Cloud_state, Particles, Precip_state, Cloud_processes, & Removal_mp, Aerosol) @@ -469,6 +505,8 @@ subroutine ls_cloud_microphysics ( & integer, intent(in) :: is, ie, js, je real, intent(in) :: dt type(aerosol_type), intent(in), optional :: Aerosol +real, intent(in), dimension(:,:) :: lon, lat + !------------------------------------------------------------------------ ! local variables: @@ -482,7 +520,9 @@ subroutine ls_cloud_microphysics ( & size(Input_mp%tin,3)) :: & delp, delz, & ST_micro, SQ_micro, SL_micro, SI_micro, & - SN_micro, SNI_micro, D_eros_l, D_eros_i, & + SN_micro, SNI_micro, & + SR_micro, SS_micro, SNR_micro,SNS_micro,& + D_eros_l, D_eros_i, & nerosc, nerosi, dqcdt, dqidt, qa_new, & ssat_disposal, ql_new, qi_new, & nctend, nitend, qn_new, qni_new, & @@ -490,7 +530,7 @@ subroutine ls_cloud_microphysics ( & accre_enhann, tnd_qsnown, & tnd_nsnown, re_icen, relvarn, & crystal1, rho_air, & - aerosols_concen, droplets_concen + aerosols_concen, droplets_concen, test_bqx, dte3d real, dimension( size(Input_mp%tin,1), size(Input_mp%tin,2), & size(Input_mp%tin,3),4) :: & @@ -565,107 +605,30 @@ subroutine ls_cloud_microphysics ( & Tend_mp%q_tnd(:,:,:,nqni) = Cloud_state%SNI_out(:,:,:) call mpp_clock_end (rk_micro_clock) -!----------------------------------------------------------------------- -! lin cld microphysics is activated -!----------------------------------------------------------------------- - else if (do_lin_cld_microphys ) then - call mpp_clock_begin (lin_micro_clock) - do k=1,kx - delp(:,:,k) = & - Input_mp%phalf(:,:,k+1) - Input_mp%phalf(:,:,k) - delz(:,:,k) = & - (Input_mp%zhalf(:,:,k+1) - Input_mp%zhalf(:,:,k))*& - Input_mp%tin(:,:,k)/Input_mp%tm(:,:,k) - end do - -!------------------------------------------------------------------------ -! droplet number concentration in #/cc following Boucher and Lohmann 1995 -! the lin microphysics uses #/cc -!------------------------------------------------------------------------ - do k=1,kx - do j=1,jx - do i=1,ix - depth = (Input_mp%phalf(i,j,k+1) - Input_mp%phalf(i,j,k)) / & - ( 9.8*0.029*Input_mp%pfull(i,j,k )/(8.314* & - Input_mp%tin(i,j,k))) -!sulfate concentration in ug/m3 - aerosols_concen(i,j,k)=(Aerosol%aerosol(i,j,k,1))/depth*1.e9 - if ( Input_mp%lat(i,j) < -1.0472 ) then ! South of ~60S are treated as ocean - droplets_concen(i,j,k)= 10.**2.06* & - (0.7273*aerosols_concen(i,j,k))**0.48 - else - droplets_concen(i,j,k)= Input_mp%land(i,j) *(10.**2.24* & - (0.7273*aerosols_concen(i,j,k))**0.257)+ & - (1.-Input_mp%land(i,j))* (10.**2.06* & - (0.7273*aerosols_concen(i,j,k))**0.48) - endif - enddo - enddo - end do - - call lin_cld_microphys_driver( & - Input_mp%qin, Input_mp%tracer(:,:,:,nql), & - Input_mp%tracer(:,:,:,nqr), Input_mp%tracer(:,:,:,nqi), & - Input_mp%tracer(:,:,:,nqs), Input_mp%tracer(:,:,:,nqg), & - Input_mp%tracer(:,:,:,nqa), droplets_concen,Tend_mp%qtnd, & - Tend_mp%q_tnd(:,:,:,nql), Tend_mp%q_tnd(:,:,:,nqr), & - Tend_mp%q_tnd(:,:,:,nqi), Tend_mp%q_tnd(:,:,:,nqs), & - Tend_mp%q_tnd(:,:,:,nqg), tend_mp%q_tnd(:,:,:,nqa), & - Tend_mp%ttnd, Input_mp%tin, Input_mp%w, Input_mp%uin, & - Input_mp%vin, Output_mp%udt, Output_mp%vdt, delz, delp, & - Input_mp%area, dt, Input_mp%land, Precip_state%surfrain, & - Precip_state%surfsnow, ice_lin, graupel_lin, & - is, ie, js, je, 1, kx, ktop, kx, Time) - -!----------------------------------------------------------------------- -! Add all "solid" form of precipitation into surf_snow -!----------------------------------------------------------------------- - Precip_state%surfsnow = (Precip_state%surfsnow + ice_lin + & - graupel_lin) * dt/86400. - Precip_state%surfrain = Precip_state%surfrain * dt/86400. - -!----------------------------------------------------------------------- -! Update tendencies: -!----------------------------------------------------------------------- - Output_mp%rdt(:,:,:,nqr) = Output_mp%rdt(:,:,:,nqr) + & - Tend_mp%q_tnd(:,:,:,nqr) - Output_mp%rdt(:,:,:,nqs) = Output_mp%rdt(:,:,:,nqs) + & - Tend_mp%q_tnd(:,:,:,nqs) - Output_mp%rdt(:,:,:,nqg) = Output_mp%rdt(:,:,:,nqg) + & - Tend_mp%q_tnd(:,:,:,nqg) - Tend_mp%ttnd = Tend_mp%ttnd * dt - Tend_mp%qtnd = Tend_mp%qtnd * dt - Tend_mp%q_tnd(:,:,:,nql) = Tend_mp%q_tnd(:,:,:,nql) * dt - Tend_mp%q_tnd(:,:,:,nqi) = Tend_mp%q_tnd(:,:,:,nqi) * dt - Tend_mp%q_tnd(:,:,:,nqa) = Tend_mp%q_tnd(:,:,:,nqa) * dt - -!----------------------------------------------------------------------- -! Update rain_wat, snow_wat, graupel_wat -!----------------------------------------------------------------------- - Input_mp%tracer(:,:,:,nqr) = Input_mp%tracer(:,:,:,nqr) + & - Tend_mp%q_tnd(:,:,:,nqr)*dt - Input_mp%tracer(:,:,:,nqs) = Input_mp%tracer(:,:,:,nqs) + & - Tend_mp%q_tnd(:,:,:,nqs)*dt - Input_mp%tracer(:,:,:,nqg) = Input_mp%tracer(:,:,:,nqg) + & - Tend_mp%q_tnd(:,:,:,nqg)*dt - call mpp_clock_end (lin_micro_clock) - !----------------------------------------------------------------------- ! NCAR microphysics (currently 3 flavors) !----------------------------------------------------------------------- else if (do_mg_microphys .or. & do_mg_ncar_microphys .or. & - do_ncar_microphys) then + do_ncar_microphys .or. & + do_ncar_MG2 ) then call mpp_clock_begin (ncar_micro_clock) + ST_micro(:,:,:) = 0.0 + SQ_micro(:,:,:) = 0.0 + SL_micro(:,:,:) = 0.0 + SI_micro(:,:,:) = 0.0 + SN_micro(:,:,:) = 0.0 + SNI_micro(:,:,:) = 0.0 + + SR_micro(:,:,:) = 0.0 + SNR_micro(:,:,:) = 0.0 + SS_micro(:,:,:) = 0.0 + SNS_micro(:,:,:) = 0.0 + !----------------------------------------------------------------------- ! determine whether NCAR microphysics are active at the current time !----------------------------------------------------------------------- - call get_time( time, current_sec, current_days) - current_total_sec = real(current_sec - current_sec0) + & - 86400.0*(current_days - current_days0) - - if (current_total_sec >= micro_begin_sec) then Atmos_state%tn = Input_mp%tin + Tend_mp%ttnd Atmos_state%qvn = Input_mp%qin + Tend_mp%qtnd @@ -692,7 +655,7 @@ subroutine ls_cloud_microphysics ( & Cloud_processes%D_eros(i,j,k)/ & dtcloud if (Cloud_state%ql_upd(i,j,k) >= qmin) then - nerosc(i,j,k) = D_eros_l(i,j,k)/ & + nerosc(i,j,k) = liq_num_eros_fac * D_eros_l(i,j,k)/ & Cloud_state%ql_upd(i,j,k)* & Cloud_state%qn_upd(i,j,k)/MAX(0.0001, & Cloud_state%qa_upd(i,j,k)) @@ -700,7 +663,7 @@ subroutine ls_cloud_microphysics ( & nerosc(i,j,k) = 0. endif if (Cloud_state%qi_upd(i,j,k) >= qmin) then - nerosi(i,j,k) = D_eros_i(i,j,k)/ & + nerosi(i,j,k) = ice_num_eros_fac * D_eros_i(i,j,k)/ & Cloud_state%qi_upd(i,j,k)* & Cloud_state%qni_upd(i,j,k)/MAX(0.0001, & Cloud_state%qa_upd(i,j,k)) @@ -755,7 +718,7 @@ subroutine ls_cloud_microphysics ( & if (do_mg_microphys) then !----------------------------------------------------------------------- -! define activated droplets in units of #/kg (drop1 is #/cc). +! define activated droplets in units of #/kg (drop1 is in-cloud #/cc). !----------------------------------------------------------------------- Particles%drop2 = Particles%drop1*1.e6/Atmos_state%airdens @@ -817,7 +780,8 @@ subroutine ls_cloud_microphysics ( & !------------------------------------------------------------------------- ! executed for mg_ncar or ncar microphysics: !------------------------------------------------------------------------- - else if (do_mg_ncar_microphys .or. do_ncar_microphys) then + else if (do_mg_ncar_microphys .or. do_ncar_microphys & + .or. do_ncar_MG2 ) then rho = Input_mp%pfull/(RDGAS*Atmos_state%tn) @@ -1038,6 +1002,7 @@ subroutine ls_cloud_microphysics ( & call write_debug_output (" ST samp bef mg ", & Tend_mp%ttnd, j=j) + !------------------------------------------------------------------------- ! call the ncar microphysics routine micro_mg_tend. !------------------------------------------------------------------------- @@ -1132,36 +1097,176 @@ subroutine ls_cloud_microphysics ( & Precip_state%surfrain(i,j) *1000.0 enddo enddo - endif ! (do_mg) - endif ! (do_mg) + + else if (do_ncar_MG2) then + nlev = kx + top_lev = 1 + mgncol = ix + accre_enhann(:,:,:) = accretion_scale ! accretion enhancement factor + + call get_time( time, current_sec, current_days) + ! if ( mpp_pe() == mpp_root_pe() ) & + ! write(*,*) 'current_sec =', current_sec + + do k=1,kx + do j=1,jx + do i=1,ix + if ( Atmos_state%tn(i,j,k) .lt.-150.0+273.15 .or. & + Atmos_state%tn(i,j,k) .gt.90+273.15) & + write(*,'(a,3i5, 5f12.5, 15e12.3)') 'before MG2: bad temperature@1213', & + i,j,k, current_sec/3600.0, Atmos_state%tn(i,j,k), Atmos_state%qvn(i,j,k), Input_mp%pfull(i,j,k), dtcloud + + enddo + enddo + enddo + + do j=1,jx + call micro_mg2_tend ( lon(:,j), lat(:,j), & + dqa_activation, total_activation, & + tiedtke_macrophysics, j, jx, & + mgncol, nlev, dtcloud, & + Particles%concen_dust_sub(:,j,:), & + Atmos_state%tn(:,j,:), & + Atmos_state%qvn(:,j,:), & + Cloud_state%ql_upd(:,j,:), Cloud_state%qi_upd(:,j,:), & + Cloud_state%qn_upd(:,j,:), Cloud_state%qni_upd(:,j,:), & + Cloud_state%qr_upd(:,j,:), Cloud_state%qs_upd(:,j,:), & + Cloud_state%qnr_upd(:,j,:), Cloud_state%qns_upd(:,j,:), & + relvarn(:,j,:), accre_enhann(:,j,:), & + Input_mp%pfull(:,j,:), & + Atmos_state%delp(:,j,:), & + Input_mp%zhalf(:,j,:), & + Cloud_state%qa_upd(:,j,:), & + liqcldf(:,j,:) , icecldf(:,j,:), & + Cloud_processes%delta_cf(:,j,:), & + D_eros_l(:,j,:), nerosc(:,j,:), & + D_eros_i(:,j,:), nerosi(:,j,:), & + dqcdt(:,j,:), dqidt(:,j,:), & + crystal1(:,j,:), & + Particles%drop2(:,j,:), & + rbar_dust_4bin(:,j,:,:), ndust_4bin(:,j,:,:), & + ST_micro(:,j,:), SQ_micro(:,j,:), SL_micro(:,j,:), & + SI_micro(:,j,:), SN_micro(:,j,:), SNI_micro(:,j,:), & + SR_micro(:,j,:), SS_micro(:,j,:), SNR_micro(:,j,:), SNS_micro(:,j,:),& + Precip_state%surfrain(:,j), & + Precip_state%surfsnow(:,j), & + Precip_state%lsc_snow(:,j,:), & + Removal_mp%rain3d(:,j,:), & + Removal_mp%snow3d(:,j,:), & + Precip_state%lsc_rain(:,j,:), & + Precip_state%lsc_rain_size(:,j,:), & + Precip_state%lsc_snow_size(:,j,:), & + errstring, Cloud_processes%f_snow_berg(:,j,:), & + ssat_disposal (:,j,:), & + Lsdiag_mp_control%n_diag_4d, Lsdiag_mp%diag_4d, & + Lsdiag_mp_control%diag_id, & + Lsdiag_mp_control%diag_pt) +!Convert from effective radius to diameter for use in radiation. +! in old NCAR, diameter was returned from mmicro_pcond routine. + Precip_state%lsc_rain_size(:,j,:) = & + 2.0*Precip_state%lsc_rain_size(:,j,:) + Precip_state%lsc_snow_size(:,j,:) = & + 2.0*Precip_state%lsc_snow_size(:,j,:) + + if(maxval(Removal_mp%snow3d(:,j,:)) > 1.e-2) write(*,*) 'max snow3d',maxval(Removal_mp%snow3d(:,j,:)) + if(minval(Removal_mp%snow3d(:,j,:)) <-1.e-2) write(*,*) 'min snow3d',minval(Removal_mp%snow3d(:,j,:)) + + do i=1,ix + do k=1,kx + if( Cloud_state%qn_upd(i,j,k) + dtcloud * SN_micro(i,j,k) < -1.e-3 ) then + print*, 'negative drop number @1281', lon(i,j), lat(i,j), k, Cloud_state%qn_upd(i,j,k), & + SN_micro(i,j,k), Cloud_state%qn_upd(i,j,k) + dtcloud * SN_micro(i,j,k) + endif + + if( Cloud_state%qr_upd(i,j,k) + dtcloud * SR_micro(i,j,k) < -1.e-3 ) then + print*, 'negative rain mass @1281', lon(i,j), lat(i,j), k, Cloud_state%qr_upd(i,j,k), & + SR_micro(i,j,k), Cloud_state%qr_upd(i,j,k) + dtcloud * SR_micro(i,j,k) + endif + + if( Cloud_state%qnr_upd(i,j,k) + dtcloud * SNR_micro(i,j,k) < -1.e-3 ) then + print*, 'negative rain number @1281', lon(i,j), lat(i,j), k, Cloud_state%qnr_upd(i,j,k), & + SNR_micro(i,j,k), Cloud_state%qnr_upd(i,j,k) + dtcloud * SNR_micro(i,j,k) + endif + + if( Cloud_state%qs_upd(i,j,k) + dtcloud * SS_micro(i,j,k) < -1.e-3 ) then + print*, 'negative snow mass @1281', lon(i,j), lat(i,j), k, Cloud_state%qs_upd(i,j,k), & + SS_micro(i,j,k), Cloud_state%qs_upd(i,j,k) + dtcloud * SS_micro(i,j,k) + endif + + if( Cloud_state%qns_upd(i,j,k) + dtcloud * SNS_micro(i,j,k) < -1.e-3 ) then + print*, 'negative snow number @1281', lon(i,j), lat(i,j), k, Cloud_state%qns_upd(i,j,k), & + SNS_micro(i,j,k), Cloud_state%qns_upd(i,j,k) + dtcloud * SNS_micro(i,j,k) + endif + enddo + enddo + + enddo ! end of j loop + +!------------------------------------------------------------------------ +! calculate column enthalpy and total water changes +! Note: in MG2, temperature tendency is multiplied by Cp_air. +!------------------------------------------------------------------------ + enth_micro_col(:,:) = 0.0 + wat_micro_col(:,:) = 0.0 + do j=1,jx + do i=1,ix + do k=1,kx + enth_micro_col(i,j) = enth_micro_col(i,j) + & + ( ST_micro(i,j,k) - HLV*SL_micro(i,j,k) - & + HLS*SI_micro(i,j,k) )* & + Atmos_state%delp(i,j,k)/grav + + wat_micro_col(i,j) = wat_micro_col(i,j) + & + ( SQ_micro(i,j,k) + SL_micro(i,j,k) + & + SI_micro(i,j,k) )* & + Atmos_state%delp(i,j,k)/grav + enddo + + enth_micro_col(i,j) = enth_micro_col(i,j) + & + (-HLV*1000.0* & + (Precip_state%surfrain(i,j) - & + Precip_state%surfsnow(i,j)) - & + HLS*1000.0 * Precip_state%surfsnow(i,j) ) + + wat_micro_col(i,j) = wat_micro_col(i,j) + & + Precip_state%surfrain(i,j) *1000.0 + enddo + enddo + + endif ! do_mg_ncar_microphys + endif ! if do_mg_microphys, elseif do_mg_ncar_microphys .or. do_ncar_microphys & .or. do_ncar_MG2 !------------------------------------------------------------------------ ! adjust precip fields to assure mass conservation and realizable ! values. !------------------------------------------------------------------------ call adjust_precip_fields ( & - ix, jx, kx, SQ_micro, SL_micro, SI_micro, & + ix, jx, kx, SQ_micro, SL_micro, SI_micro, SR_micro, SS_micro, & Atmos_state, Precip_state, Lsdiag_mp, & Lsdiag_mp_control ) !----------------------------------------------------------------------- ! update prognostic tendencies due to microphysics terms. !----------------------------------------------------------------------- - Tend_mp%qtnd = Tend_mp%qtnd + SQ_micro*dtcloud - Tend_mp%ttnd = Tend_mp%ttnd + ST_micro/cp_air*dtcloud - Tend_mp%q_tnd(:,:,:,nql) = Tend_mp%q_tnd(:,:,:,nql) + & - SL_micro(:,:,:)*dtcloud - Tend_mp%q_tnd(:,:,:,nqi) = Tend_mp%q_tnd(:,:,:,nqi) + & - SI_micro(:,:,:)*dtcloud - Tend_mp%q_tnd(:,:,:,nqn) = Tend_mp%q_tnd(:,:,:,nqn) + & - SN_micro(:,:,:)*dtcloud - Tend_mp%q_tnd(:,:,:,nqni)= Tend_mp%q_tnd(:,:,:,nqni) + & - SNI_micro(:,:,:)*dtcloud + Tend_mp%qtnd = Tend_mp%qtnd + SQ_micro*dtcloud + Tend_mp%ttnd = Tend_mp%ttnd + ST_micro/cp_air*dtcloud + Cloud_state%SL_out = Cloud_state%SL_out + SL_micro*dtcloud + Cloud_state%SI_out = Cloud_state%SI_out + SI_micro*dtcloud + Cloud_state%SN_out = Cloud_state%SN_out + SN_micro*dtcloud + Cloud_state%SNI_out = Cloud_state%SNI_out + SNI_micro*dtcloud - Cloud_state%SL_out = Cloud_state%SL_out + SL_micro*dtcloud - Cloud_state%SI_out = Cloud_state%SI_out + SI_micro*dtcloud - Cloud_state%SN_out = Cloud_state%SN_out + SN_micro*dtcloud - Cloud_state%SNI_out = Cloud_state%SNI_out + SNI_micro*dtcloud + if (nqr /= NO_TRACER) then + Cloud_state%SR_out = Cloud_state%SR_out + SR_micro*dtcloud + endif + if (nqs /= NO_TRACER) then + Cloud_state%SS_out = Cloud_state%SS_out + SS_micro*dtcloud + endif + if (nqnr /= NO_TRACER) then + Cloud_state%SNR_out = Cloud_state%SNR_out + SNR_micro*dtcloud + endif + if (nqns /= NO_TRACER) then + Cloud_state%SNS_out = Cloud_state%SNS_out + SNS_micro*dtcloud + endif !------------------------------------------------------------------------ ! adjustment to fields needed after removing supersaturation (only @@ -1234,6 +1339,14 @@ subroutine ls_cloud_microphysics ( & Tend_mp%q_tnd(:,:,:,nqn) = Cloud_state%SN_out(:,:,:) if (nqni /= NO_TRACER) & Tend_mp%q_tnd(:,:,:,nqni) = Cloud_state%SNI_out(:,:,:) + if (nqr /= NO_TRACER) & + Tend_mp%q_tnd(:,:,:,nqr) = Cloud_state%SR_out(:,:,:) + if (nqs /= NO_TRACER) & + Tend_mp%q_tnd(:,:,:,nqs) = Cloud_state%SS_out(:,:,:) + if (nqnr /= NO_TRACER) & + Tend_mp%q_tnd(:,:,:,nqnr) = Cloud_state%SNR_out(:,:,:) + if (nqns /= NO_TRACER) & + Tend_mp%q_tnd(:,:,:,nqns) = Cloud_state%SNS_out(:,:,:) !----------------------------------------------------------------------- ! define the total precipitating ice field for use in COSP (stored in @@ -1244,7 +1357,6 @@ subroutine ls_cloud_microphysics ( & Removal_mp%snowclr3d = Removal_mp%snow3d endif ! do_clubb - endif ! current_total_sec >= micro_begin_sec call mpp_clock_end (ncar_micro_clock) !------------------------------------------------------------------------- @@ -1332,7 +1444,7 @@ end subroutine ls_cloud_microphysics_end !######################################################################## subroutine adjust_precip_fields ( & - ix, jx, kx, SQ_micro, SL_micro, SI_micro, & + ix, jx, kx, SQ_micro, SL_micro, SI_micro, SR_micro, SS_micro, & Atmos_state, Precip_state, Lsdiag_mp, & Lsdiag_mp_control ) @@ -1348,7 +1460,7 @@ subroutine adjust_precip_fields ( & type(mp_lsdiag_control_type), intent(inout) :: Lsdiag_mp_control type(atmos_state_type), intent(inout) :: Atmos_state type(precip_state_type), intent(inout) :: Precip_state -real, dimension (:,:,:), intent(in) :: SL_micro, SI_micro, SQ_micro +real, dimension (:,:,:), intent(in) :: SL_micro, SI_micro, SQ_micro, SR_micro, SS_micro !---------------------------------------------------------------------- @@ -1368,7 +1480,7 @@ subroutine adjust_precip_fields ( & m1(i,j) = 0. do k=1,kx m1(i,j) = m1(i,j) + & - (SQ_micro(i,j,k) + SL_micro(i,j,k) + SI_micro(i,j,k))* & + (SQ_micro(i,j,k) + SL_micro(i,j,k) + SI_micro(i,j,k) + SR_micro(i,j,k) + SS_micro(i,j,k) )* & dtcloud*Atmos_state%delp(i,j,k)/grav end do m2(i,j) = 1.e3*Precip_state%surfrain(i,j)*dtcloud @@ -1452,9 +1564,7 @@ subroutine adjust_precip_fields ( & end subroutine adjust_precip_fields - - -!######################################################################### +!######################################################################## subroutine adjust_for_supersaturation_removal ( & ix, jx, kx, C2ls_mp, Input_mp, Atmos_state, & @@ -1522,7 +1632,7 @@ subroutine adjust_for_supersaturation_removal ( & ! proportional to the cloud area increase. save the incremental ! increase due to removing superstauration as diagnostics. !----------------------------------------------------------------------- - if (dqa_activation) then + ! if (dqa_activation) then ! h1g, 2020-03-19 if (ssat_disposal(i,j,k) == 2.) then Cloud_state%SNi_out(i,j,k) = & Cloud_state%SNi_out(i,j,k) + & @@ -1551,7 +1661,7 @@ subroutine adjust_for_supersaturation_removal ( & (1. - Cloud_state%qa_upd(i,j,k) - tmp2s(i,j,k))/ & dtcloud endif - end if ! dqa_activation + ! end if ! dqa_activation ! h1g, 2020-03-19 if (max(Lsdiag_mp_control%diag_id%qadt_super, & Lsdiag_mp_control%diag_id%qa_super_col) > 0) then Lsdiag_mp%diag_4d(i,j,k, & @@ -1606,7 +1716,7 @@ subroutine destroy_tiny_clouds ( & real, dimension (ix,jx,kx) :: ql_new, qi_new, qn_new, qni_new, & qa_new integer :: i,j,k - + real, dimension (ix,jx,kx) :: qr_new, qnr_new, qs_new, qns_new !----------------------------------------------------------------------- ! define current cloud and particle values. @@ -1616,6 +1726,10 @@ subroutine destroy_tiny_clouds ( & qn_new = Cloud_state%qn_in + Cloud_state%SN_out qni_new = Cloud_state%qni_in + Cloud_state%SNi_out + qr_new = Cloud_state%qr_in + Cloud_state%SR_out + qnr_new = Cloud_state%qnr_in + Cloud_state%SNR_out + qs_new = Cloud_state%qs_in + Cloud_state%SS_out + qns_new = Cloud_state%qns_in + Cloud_state%SNS_out !----------------------------------------------------------------------- ! if these values are lower than acceptable, or if the new cloud area ! is lower than acceptable, set the tendency to balance the input value, @@ -1685,6 +1799,8 @@ subroutine destroy_tiny_clouds ( & !----------------------------------------------------------------------- ! redefine the new cloud tracer values. !----------------------------------------------------------------------- + + if ( do_cleanup ) then ! --> h1g, 20200317 ql_new = Cloud_state%ql_in + Cloud_state%SL_out qi_new = Cloud_state%qi_in + Cloud_state%SI_out qn_new = Cloud_state%qn_in + Cloud_state%SN_out @@ -1828,6 +1944,7 @@ subroutine destroy_tiny_clouds ( & end do end do + endif ! do_cleanup --> h1g 20200317 !---------------------------------------------------------------------- ! make sure the new cloud area is not smaller than the minimum ! allowable. if not set the tendency so that cloud area is reduced to @@ -1861,7 +1978,7 @@ subroutine destroy_tiny_clouds ( & ! microphysics, as part of the destruction diagnostic. !------------------------------------------------------------------------ if (do_mg_ncar_microphys .or. do_ncar_microphys .or. & - do_mg_microphys) then + do_mg_microphys .or. do_ncar_MG2 ) then if (Lsdiag_mp_control%diag_id%qadt_limits + & Lsdiag_mp_control%diag_id%qa_limits_col > 0) & Lsdiag_mp%diag_4d(:,:,:,Lsdiag_mp_control%diag_pt%qadt_limits) = & @@ -1879,9 +1996,69 @@ subroutine destroy_tiny_clouds ( & inv_dtcloud endif -!----------------------------------------------------------------------- - +! rain destruction + if ( do_ncar_MG2 ) then + do k=1,kx + do j=1,jx + do i=1,ix + if ( qr_new(i,j,k) <= qmin .or. qnr_new(i,j,k) <= qmin ) then + Cloud_state%SR_out(i,j,k) = Cloud_state%SR_out(i,j,k) - & + qr_new(i,j,k) + Cloud_state%SNR_out(i,j,k) = Cloud_state%SNR_out(i,j,k) - & + qnr_new(i,j,k) + + Tend_mp%qtnd(i,j,k) = Tend_mp%qtnd(i,j,k) + qr_new(i,j,k) + Tend_mp%ttnd(i,j,k) = Tend_mp%ttnd(i,j,k) - (hlv*qr_new(i,j,k))/cp_air + + if (Lsdiag_mp_control%diag_id%qrdt_destr > 0 .or. & + Lsdiag_mp_control%diag_id%qr_destr_col > 0) & + Lsdiag_mp%diag_4d(i,j,k,Lsdiag_mp_control%diag_pt%qrdt_destr) = & + - qr_new(i,j,k)/dtcloud + if (Lsdiag_mp_control%diag_id%qnrdt_destr > 0 .or. & + Lsdiag_mp_control%diag_id%qnr_destr_col > 0) & + Lsdiag_mp%diag_4d(i,j,k,Lsdiag_mp_control%diag_pt%qnrdt_destr) = & + - qnr_new(i,j,k)/dtcloud + if (Lsdiag_mp_control%diag_id%qdt_destr + & + Lsdiag_mp_control%diag_id%q_destr_col > 0) & + Lsdiag_mp%diag_4d(i,j,k,Lsdiag_mp_control%diag_pt%qdt_destr) = & + Lsdiag_mp%diag_4d(i,j,k,Lsdiag_mp_control%diag_pt%qdt_destr) + & + qr_new(i,j,k)/dtcloud + endif + enddo + enddo + enddo +! snow destruction + do k=1,kx + do j=1,jx + do i=1,ix + if ( qs_new(i,j,k) <= qmin .or. qns_new(i,j,k) <= qmin) then + Cloud_state%SS_out(i,j,k) = Cloud_state%SS_out(i,j,k) - & + qs_new(i,j,k) + Cloud_state%SNS_out(i,j,k) = Cloud_state%SNS_out(i,j,k) - & + qns_new(i,j,k) + Tend_mp%qtnd(i,j,k) = Tend_mp%qtnd(i,j,k) + qs_new(i,j,k) + Tend_mp%ttnd(i,j,k) = Tend_mp%ttnd(i,j,k) - (hls*qs_new(i,j,k))/cp_air + + if (Lsdiag_mp_control%diag_id%qsdt_destr > 0 .or. & + Lsdiag_mp_control%diag_id%qs_destr_col > 0) & + Lsdiag_mp%diag_4d(i,j,k,Lsdiag_mp_control%diag_pt%qsdt_destr) = & + - qs_new(i,j,k)/dtcloud + if (Lsdiag_mp_control%diag_id%qnsdt_destr > 0 .or. & + Lsdiag_mp_control%diag_id%qns_destr_col > 0) & + Lsdiag_mp%diag_4d(i,j,k,Lsdiag_mp_control%diag_pt%qnsdt_destr) = & + - qns_new(i,j,k)/dtcloud + if (Lsdiag_mp_control%diag_id%qdt_destr + & + Lsdiag_mp_control%diag_id%q_destr_col > 0) & + Lsdiag_mp%diag_4d(i,j,k,Lsdiag_mp_control%diag_pt%qdt_destr) = & + Lsdiag_mp%diag_4d(i,j,k,Lsdiag_mp_control%diag_pt%qdt_destr) + & + qs_new(i,j,k)/dtcloud + endif + enddo + enddo + enddo + endif ! do_ncar_MG2 +!----------------------------------------------------------------------- end subroutine destroy_tiny_clouds diff --git a/atmos_param/microphysics/micro_mg2.F90 b/atmos_param/microphysics/micro_mg2.F90 new file mode 100644 index 00000000..aed9f287 --- /dev/null +++ b/atmos_param/microphysics/micro_mg2.F90 @@ -0,0 +1,4285 @@ + +#define GFDL_COMPATIBLE_MICROP + +module micro_mg2_mod + +! this is ncar routine micro_mg2 + +!--------------------------------------------------------------------------------- +! Purpose: +! MG microphysics version 2, prognostic precipitation. +! point for the development of MG2 +! +! Author: Andrew Gettelman, Hugh Morrison. +! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan +!! +! NOTE: If do_cldice is false, then MG microphysics should not update CLDICE +! or NUMICE; however, it is assumed that the other microphysics scheme will have +! updated CLDICE and NUMICE. The other microphysics should handle the following +! processes that would have been done by MG: +! - Detrainment (liquid and ice) +! - Homogeneous ice nucleation +! - Heterogeneous ice nucleation +! - Bergeron process +! - Melting of ice +! - Freezing of cloud drops +! - Autoconversion (ice -> snow) +! - Growth/Sublimation of ice +! - Sedimentation of ice +!--------------------------------------------------------------------------------- +! Based on micro_mg (restructuring of former cldwat2m_micro) +! Author: Andrew Gettelman, Hugh Morrison. +! Contributions from: Xiaohong Liu and Steve Ghan +! December 2005-May 2010 +! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) +! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +!--------------------------------------------------------------------------------- + +!-------------------------------------------------------------------------- +! Interfaces, diagnostics, used modules, constants modified for use in GFDL +! based models +! Huan Guo +!-------------------------------------------------------------------------- + +! Code comments added by HM, 093011 +! General code structure: +! +! Code is divided into two main subroutines: +! subroutine micro_mg_init --> initializes microphysics routine, should be called +! once at start of simulation +! subroutine micro_mg_tend --> main microphysics routine to be called each time step +! +! List of external functions: +! qsat_water --> for calculating saturation vapor pressure with respect to liquid water +! qsat_ice --> for calculating saturation vapor pressure with respect to ice +! gamma --> standard mathematical gamma function +! ......................................................................... +! List of inputs through use statement in fortran90: +! Variable Name Description Units +! ......................................................................... +! gravit acceleration due to gravity m s-2 +! rair dry air gas constant for air J kg-1 K-1 +! tmelt temperature of melting point for water K +! cpair specific heat at constant pressure for dry air J kg-1 K-1 +! rh2o gas constant for water vapor J kg-1 K-1 +! latvap latent heat of vaporization J kg-1 +! latice latent heat of fusion J kg-1 +! qsat_water external function for calculating liquid water +! saturation vapor pressure/humidity - +! qsat_ice external function for calculating ice +! saturation vapor pressure/humidity pa +! rhmini relative humidity threshold parameter for +! nucleating ice - +! ......................................................................... +! NOTE: List of all inputs/outputs passed through the call/subroutine statement +! for micro_mg_tend is given below at the start of subroutine micro_mg_tend. +!--------------------------------------------------------------------------------- + +! Procedures required: +! 1) An implementation of the gamma function (if not intrinsic). +! 2) saturation vapor pressure and specific humidity over water +! 3) svp over ice + +#ifdef GFDL_COMPATIBLE_MICROP +use gamma_mg_mod, only: gamma =>gamma_mg +use lscloud_types_mod, only: diag_id_type, diag_pt_type + +use mpp_mod, only: input_nml_file +use fms_mod, only: mpp_pe, error_mesg, & + FATAL, & + stdlog, write_version_number, & + check_nml_error, & + mpp_root_pe, mpp_chksum +!use simple_pdf_mod, only: simple_pdf +use sat_vapor_pres_mod, only: lookup_es2, lookup_es3, compute_qs +use physics_radiation_exch_mod, only : exchange_control_type + +#endif + +! Parameters from the utilities module. +use micro_mg2_utils, only: & + r8, & + pi, & + omsm, & + qsmall, & + mincld, & + rhosn, & + rhoi, & + rhow, & + rhows, & + ac, bc, & + ai, bi, & + aj, bj, & + ar, br, & + as, bs, & + mi0, & + rising_factorial + +! Constituent properties. +use micro_mg2_utils, only: & + mg_liq_props, & + mg_ice_props, & + mg_rain_props, & + mg_snow_props + +! Size calculation functions. +use micro_mg2_utils, only: & + size_dist_param_liq, & + size_dist_param_basic, & + avg_diameter + + +use micro_mg2_utils, only: & + micro_mg_utils_init, & + size_dist_param_liq, & + size_dist_param_basic, & + avg_diameter, & + rising_factorial, & + ice_deposition_sublimation, & + sb2001v2_liq_autoconversion,& + sb2001v2_accre_cld_water_rain,& + kk2000_liq_autoconversion, & + ice_autoconversion, & + immersion_freezing, & + contact_freezing, & + 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, & + evaporate_sublimate_precip, & + bergeron_process_snow, & ! h1g, 2020-03-23 + cotton_liq_autoconversion ! h1g, 2020-03-23 + + +implicit none +private +save + +public :: & + micro_mg2_init, & + micro_mg2_get_cols, & + micro_mg2_tend + +!------------------------------------------------------------------------ +!--version number-------------------------------------------------------- + +character(len=128) :: Version = '$Id: micro_mg2.F90,v 1.1.2.2.2.1 2017/01/23 14:50:42 Huan.Guo Exp $' +character(len=128) :: Tagname = '$Name: $' + +!========================================================= +! Constants set in initialization +!========================================================= + +! Set using arguments to micro_mg_init +real(r8) :: g ! gravity +real(r8) :: r ! dry air gas constant +real(r8) :: rv ! water vapor gas constant +real(r8) :: cpp ! specific heat of dry air +real(r8) :: tmelt ! freezing point of water (K) + +! latent heats of: +real(r8) :: xxlv ! vaporization +real(r8) :: xlf ! freezing +real(r8) :: xxls ! sublimation + +real(r8) :: rhosu ! typical 850mn air density + +real(r8) :: icenuct ! ice nucleation temperature: currently -5 degrees C + +real(r8) :: snowmelt ! what temp to melt all snow: currently 2 degrees C +real(r8) :: rainfrze ! what temp to freeze all rain: currently -5 degrees C + +real :: dcs !autoconversion size threshold +logical :: rho_factor_in_max_vt = .true. +real :: max_rho_factor_in_vt = 1.0 + +! switch for specification rather than prediction of droplet and crystal number +! note: number will be adjusted as needed to keep mean size within bounds, +! even when specified droplet or ice number is used + +! ***note: Even if constant cloud ice number is set, ice number is allowed +! to evolve based on process rates. This is needed in order to calculate +! the change in mass due to ice nucleation. All other ice microphysical +! processes are consistent with the specified constant ice number if +! this switch is turned on. + +! nccons = .true. to specify constant cloud droplet number +! nicons = .true. to specify constant cloud ice number + +logical :: nccons = .false. +logical :: nicons = .false. + +! parameters for specified ice and droplet number concentration +! note: these are local in-cloud values, not grid-mean +real(r8) :: ncnst = 100.e6_r8 ! droplet num concentration when + ! nccons=.true. (m-3) +real(r8) :: ninst = 0.1e6_r8 ! ice num concentration when + ! nicons=.true. (m-3) +! <---h1g, 2012-06-12 +logical :: liu_in = .false. + ! True = Liu et al 2007 Ice nucleation + ! False = cooper fixed ice nucleation (MG2008) + +logical :: use_Meyers = .false. +! Ni (/m3) = 1000 * exp( (12.96* [(esl-esi)/esi]) - 0.639 ) +! Figure 9.3 of Rogers and Yau (1998) shows the nearly linear +! variation of [(esl-esi)/esi] from 0. at 273.16K to 0.5 at +! 233.16K. Analytically this is parameterized as (tfreeze-T)/80. +! +! Ni (/m3) = 1000 * exp( 12.96* (tfreeze-T)/80 - 0.639 ) + +logical :: use_Fan2019 = .false. +real(r8) :: Nice_max_Fan = 40.0 + +!---> h1g, 2014-05-19 +real :: tc_cooper = -35.0 +real :: IceFallFac = 1.0 +real :: SnowFallFac = 1.0 +logical :: include_contact_freeze_in_berg = .false. + +character(len=16) :: micro_mg_precip_frac_method = "max_overlap" ! type of precipitation fraction method +real(r8) :: micro_mg_bergs_eff_factor = 1.0_r8 ! bergs efficiency factor (liquid to snow) +real(r8) :: micro_mg_berg_eff_factor = 1.0_r8 ! berg efficiency factor (liquid to ice) + +logical :: allow_sed_supersat = .true. ! Allow supersaturated conditions after sedimentation loop + +logical :: do_sb_physics = .false. +logical :: use_hetfrz_classnuc = .false. +real :: tau_act_liq = 1800.0 +real :: tau_act_ice = 900.0 +real :: tc_act = -35.0 + +logical :: allow_rain_num_evap = .false. +logical :: allow_snow_num_sublimation = .false. + +logical :: no_evap_in_sedimentation = .false. +real(r8) :: vfactor = 1.0 +real(r8) :: vfac_drop = 1.0 ! h1g, 2020-06-18 +real(r8) :: vfac_ice = 1.0 ! h1g, 2020-06-18 + +real(r8) :: icld_cri = -0.2 ! h1g, 2020-07-02 +real(r8) :: evap_subl_fac = 1.0 ! h1g, 2020-07-06 + +real(r8) :: ice_sublim_factor = 1.0 ! h1g, 2020-07-16 + +! minimum mass of new crystal due to freezing of cloud droplets done +! externally (kg) +real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3 + +real :: rhmini=0.80 ! minimum rh for ice cld fraction > 0 +logical :: microp_uniform = .false. + ! .true. = configure uniform for + ! sub-columns + ! .false. = use w/o sub-columns + ! (default) +logical :: do_cldice = .true. + ! .true. = do all processes (default) + ! .false. = skip all processes + ! affecting cloud ice +logical :: do_ice_nucl_wpdf +logical :: clubb_active +logical :: do_Ni_linear_interp = .false. +logical :: do_implicit_fall = .false. + + +logical :: do_qc_implicit_fall = .true. +logical :: do_qi_implicit_fall = .true. +logical :: do_qr_implicit_fall = .true. +logical :: do_qs_implicit_fall = .true. + + +! additional constants to help speed up code +real(r8) :: gamma_br_plus1 +real(r8) :: gamma_br_plus4 +real(r8) :: gamma_bs_plus1 +real(r8) :: gamma_bs_plus4 +real(r8) :: gamma_bi_plus1 +real(r8) :: gamma_bi_plus4 +real(r8) :: gamma_bj_plus1 +real(r8) :: gamma_bj_plus4 +real(r8) :: xxlv_squared +real(r8) :: xxls_squared +!<--- h1g, 2014-05-19 + +real(r8) :: dum_5, dum_30, dum_tmp +integer :: iter = 1 +logical :: do_liq_num_adjust = .true. +logical :: do_liq_num_riming = .true. +logical :: do_liq_num_ihom = .true. ! h1g, 2020-06-22 +logical :: do_ice_num_adjust = .true. ! h1g, 2020-07-01 + +logical :: do_cotton_auto = .false. +real(r8) :: rthresh = 8.6 +logical :: do_HM_splinter = .true. +logical :: remove_super_RK = .false. +logical :: use_const_ELI = .false. ! --> h1g, 2020-04-16 +real(r8) :: ELI_RK = 0.7 ! --> h1g, 2020-04-16 +logical :: use_FanAndCooper = .false. ! --> h1g, 2020-04-18 +real(r8) :: sublim_factor = 0.0 +real(r8) :: ice_nucl_factor = 1.0 + +namelist / micro_mg2_nml / & + max_rho_factor_in_vt, & + rho_factor_in_max_vt, & + nccons, ncnst, & ! cjg + nicons, ninst, & ! cjg + liu_in, & ! h1g + use_Meyers, tc_cooper, & !h1g + IceFallFac, SnowFallFac, & !h1g + include_contact_freeze_in_berg, & !h1g + do_sb_physics, allow_sed_supersat, & ! h1g + use_hetfrz_classnuc, micro_mg_precip_frac_method, micro_mg_berg_eff_factor, & + tau_act_liq, tau_act_ice, tc_act, allow_rain_num_evap, allow_snow_num_sublimation, & + rhmini, microp_uniform, do_cldice, do_Ni_linear_interp, & + do_implicit_fall, vfactor, no_evap_in_sedimentation, iter, & + use_Fan2019, Nice_max_Fan, & + do_qc_implicit_fall, do_qi_implicit_fall, do_qr_implicit_fall, do_qs_implicit_fall, & + do_liq_num_adjust, do_liq_num_riming, do_cotton_auto, rthresh, do_HM_splinter, & ! h1g, 2020-03-06 + remove_super_RK, use_const_ELI, ELI_RK, use_FanAndCooper, sublim_factor, & ! h1g, 2020-04-18 + ice_nucl_factor, vfac_drop, vfac_ice, do_liq_num_ihom, micro_mg_bergs_eff_factor, & ! h1g, 2020-06-22 + do_ice_num_adjust, icld_cri, evap_subl_fac, ice_sublim_factor ! h1g, 2020-07-06 + +!=============================================================================== +contains +!=============================================================================== + +subroutine micro_mg2_init( & + kind, gravit, rair, rh2o, cpair, & + tmelt_in, latvap, latice, & + ! rhmini_in, microp_uniform_in, do_cldice_in, & + do_ice_nucl_wpdf_in, errstring, Exch_ctrl) + + !----------------------------------------------------------------------- + ! + ! Purpose: + ! initialize constants for MG microphysics + ! + ! Author: Andrew Gettelman Dec 2005 + ! + !----------------------------------------------------------------------- + + integer, intent(in) :: kind ! Kind used for reals + real(r8), intent(in) :: gravit + real(r8), intent(in) :: rair + real(r8), intent(in) :: rh2o + real(r8), intent(in) :: cpair + real(r8), intent(in) :: tmelt_in ! Freezing point of water (K) + real(r8), intent(in) :: latvap + real(r8), intent(in) :: latice + + logical, intent(in) :: do_ice_nucl_wpdf_in + type(exchange_control_type), intent(in) :: Exch_ctrl + + character(128), intent(out) :: errstring ! Output status (non-blank for error return) + + INTEGER :: io, ierr, logunit + + !----------------------------------------------------------------------- + + dcs = Exch_ctrl%dcs + call micro_mg_utils_init(kind, rh2o, cpair, tmelt_in, latvap, latice, & + dcs, errstring) + + errstring = ' ' + + if( kind .ne. r8 ) then + errstring = 'micro_mg2_init: KIND of reals does not match' + return + endif + + ! declarations for MG code (transforms variable names) + + g= gravit ! gravity + r= rair ! dry air gas constant: note units(phys_constants are in J/K/kmol) + rv= rh2o ! water vapor gas constant + cpp = cpair ! specific heat of dry air + tmelt = tmelt_in + +! latent heats + xxlv = latvap ! latent heat vaporization + xlf = latice ! latent heat freezing + xxls = xxlv + xlf ! latent heat of sublimation + +!--------------------------------------------------------------- +! process namelist +!--------------------------------------------------------------- + read (input_nml_file, nml=micro_mg2_nml, iostat=io) + ierr = check_nml_error(io,'micro_mg2_nml') + +!----------------------------------------------------------------------- +! write version and namelist to stdlog. +!----------------------------------------------------------------------- + call write_version_number (version, tagname) + logunit = stdlog() + if (mpp_pe() == mpp_root_pe()) & + write (logunit, nml=micro_mg2_nml) + + do_ice_nucl_wpdf = do_ice_nucl_wpdf_in + clubb_active=(Exch_ctrl%do_clubb>0) + + ! typical air density at 850 mb + rhosu = 85000._r8/(rair * tmelt) + + ! Maximum temperature at which snow is allowed to exist + snowmelt = tmelt + 2._r8 + ! Minimum temperature at which rain is allowed to exist + rainfrze = tmelt - 40._r8 + + ! Ice nucleation temperature + icenuct = tmelt - 5._r8 + + ! Define constants to help speed up code (this limits calls to gamma function) + gamma_br_plus1=gamma(1._r8+br) + gamma_br_plus4=gamma(4._r8+br) + gamma_bs_plus1=gamma(1._r8+bs) + gamma_bs_plus4=gamma(4._r8+bs) + gamma_bi_plus1=gamma(1._r8+bi) + gamma_bi_plus4=gamma(4._r8+bi) + gamma_bj_plus1=gamma(1._r8+bj) + gamma_bj_plus4=gamma(4._r8+bj) + + xxlv_squared=xxlv**2 + xxls_squared=xxls**2 + +end subroutine micro_mg2_init + +!=============================================================================== +!microphysics routine for each timestep goes here... +subroutine micro_mg2_tend ( lon, lat, & + dqa_activation, total_activation, tiedtke_macrophysics, & + j, jdim, & + mgncol, nlev, deltatin, & + concen_dust_sub, & + tn, qn, & + qcn, qin, & + ncn, nin, & + qrn, qsn, & + nrn, nsn, & + relvar, accre_enhan, & + p, pdel, zhalf, & + cldn, liqcldf, icecldf, & + delta_cf, D_eros_l, nerosc, D_eros_i, nerosi, dqcdt, dqidt, & + naai, npccn, & + rndst, nacon, & + tlat, qvlat, & + qctend, qitend, & + nctend, nitend, & + qrtend, qstend, & + nrtend, nstend, & + prect, preci, & + qsout, rflx, sflx, & + qrout, reff_rain, reff_snow, & + errstring, & + f_snow_berg, ssat_disposal, & + n_diag_4d, diag_4l, diag_id, diag_pt) + + + ! input arguments + real(r8), intent(in) :: lon(mgncol), lat(mgncol) + + logical, intent (in) :: dqa_activation + logical, intent (in) :: total_activation + logical, intent (in) :: tiedtke_macrophysics + integer, intent(in) :: j, jdim + integer, intent(in) :: mgncol ! number of microphysics columns + integer, intent(in) :: nlev ! number of layers + real(r8), intent(in) :: deltatin ! time step (s) + + real(r8), intent(in) :: concen_dust_sub(mgncol,nlev) ! sub-micro dust aerosol concentration (ug/m3) + + real(r8), intent(in) :: tn(mgncol,nlev) ! input temperature (K) + real(r8), intent(in) :: qn(mgncol,nlev) ! input h20 vapor mixing ratio (kg/kg) + real(r8), intent(in) :: relvar(mgncol,nlev) ! relative variance of cloud water (-) + real(r8), intent(in) :: accre_enhan(mgncol,nlev) ! optional accretion enhancement factor (-) + + ! note: all input cloud variables are grid-averaged + real(r8), intent(in) :: qcn(mgncol,nlev) ! cloud water mixing ratio (kg/kg) + real(r8), intent(in) :: qin(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) + real(r8), intent(in) :: ncn(mgncol,nlev) ! cloud water number conc (1/kg) + real(r8), intent(in) :: nin(mgncol,nlev) ! cloud ice number conc (1/kg) + + real(r8), intent(in) :: qrn(mgncol,nlev) ! rain mixing ratio (kg/kg) + real(r8), intent(in) :: qsn(mgncol,nlev) ! snow mixing ratio (kg/kg) + real(r8), intent(in) :: nrn(mgncol,nlev) ! rain number conc (1/kg) + real(r8), intent(in) :: nsn(mgncol,nlev) ! snow number conc (1/kg) + + real(r8), intent(in) :: p(mgncol,nlev) ! air pressure (pa) + real(r8), intent(in) :: pdel(mgncol,nlev) ! pressure difference across level (pa) + + real(r8), intent(in) :: zhalf(mgncol,nlev+1) ! half-pressure level height (m) + ! hm add 11-16-11, interface pressure + + real(r8), intent(in) :: cldn(mgncol,nlev) ! cloud fraction (no units) + real(r8), intent(in) :: liqcldf(mgncol,nlev) ! liquid cloud fraction (no units) + real(r8), intent(in) :: icecldf(mgncol,nlev) ! ice cloud fraction (no units) + + + real(r8), intent(in) :: delta_cf(mgncol,nlev) + real(r8), intent(inout) :: D_eros_l(mgncol,nlev) + real(r8), intent(inout) :: nerosc(mgncol,nlev) + real(r8), intent(inout) :: D_eros_i(mgncol,nlev) + real(r8), intent(inout) :: nerosi(mgncol,nlev) + real(r8), intent(inout) :: dqcdt(mgncol,nlev) + real(r8), intent(inout) :: dqidt(mgncol,nlev) + + ! used for scavenging + ! Inputs for aerosol activation + real(r8), intent(inout) :: naai(mgncol,nlev) ! ice nucleation number (from microp_aero_ts) (1/kg) + real(r8), intent(in) :: npccn(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) + + ! Note that for these variables, the dust bin is assumed to be the last index. + ! (For example, in CAM, the last dimension is always size 4.) + real(r8), intent(in) :: rndst(:,:,:) ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m) + real(r8), intent(in) :: nacon(:,:,:) ! number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) + + ! output arguments + ! direct cw to precip conversion + real(r8), intent(out) :: tlat(mgncol,nlev) ! latent heating rate (W/kg) + real(r8), intent(out) :: qvlat(mgncol,nlev) ! microphysical tendency qv (1/s) + real(r8), intent(out) :: qctend(mgncol,nlev) ! microphysical tendency qc (1/s) + real(r8), intent(out) :: qitend(mgncol,nlev) ! microphysical tendency qi (1/s) + real(r8), intent(out) :: nctend(mgncol,nlev) ! microphysical tendency nc (1/(kg*s)) + real(r8), intent(out) :: nitend(mgncol,nlev) ! microphysical tendency ni (1/(kg*s)) + + real(r8), intent(out) :: qrtend(mgncol,nlev) ! microphysical tendency qr (1/s) + real(r8), intent(out) :: qstend(mgncol,nlev) ! microphysical tendency qs (1/s) + real(r8), intent(out) :: nrtend(mgncol,nlev) ! microphysical tendency nr (1/(kg*s)) + real(r8), intent(out) :: nstend(mgncol,nlev) ! microphysical tendency ns (1/(kg*s)) + + + real(r8), intent(out) :: prect(mgncol) ! surface precip rate (m/s) + real(r8), intent(out) :: preci(mgncol) ! cloud ice/snow precip rate (m/s) + + + real(r8), intent(out) :: qsout(mgncol,nlev) ! snow mixing ratio (kg/kg) + real(r8), intent(out) :: rflx(mgncol,nlev+1) ! grid-box average rain flux (kg m^-2 s^-1) + real(r8), intent(out) :: sflx(mgncol,nlev+1) ! grid-box average snow flux (kg m^-2 s^-1) + real(r8), intent(out) :: qrout(mgncol,nlev) ! grid-box average rain mixing ratio (kg/kg) + real(r8), intent(out) :: reff_rain(mgncol,nlev) ! rain effective radius (micron) + real(r8), intent(out) :: reff_snow(mgncol,nlev) ! snow effective radius (micron) + + character(128), intent(out) :: errstring ! output status (non-blank for error return) + real(r8), intent(out) :: f_snow_berg (mgncol,nlev) ! ratio of bergeron + ! production of qi to + ! sum of bergeron, + ! riming and freezing + real(r8), intent(out) :: ssat_disposal(mgncol,nlev) + ! disposition of supersaturation at end + ! of step; 0.= no ssat, 1.= liq, 2.=ice) + INTEGER,INTENT(IN) :: n_diag_4d + REAL, dimension( mgncol,jdim, nlev, 0:n_diag_4d ), INTENT(INOUT) :: diag_4l + TYPE(diag_id_type),INTENT(IN) :: diag_id + TYPE(diag_pt_type),INTENT(INout) :: diag_pt + + +!--> h1g, 2019-12-05 + ! temporary variables for sub-stepping + real(r8) :: tlat1(mgncol,nlev) + real(r8) :: qvlat1(mgncol,nlev) + real(r8) :: qctend1(mgncol,nlev) + real(r8) :: qitend1(mgncol,nlev) + real(r8) :: nctend1(mgncol,nlev) + real(r8) :: nitend1(mgncol,nlev) + real(r8) :: qrtend1(mgncol,nlev) + real(r8) :: qstend1(mgncol,nlev) + real(r8) :: nrtend1(mgncol,nlev) + real(r8) :: nstend1(mgncol,nlev) +!<-- h1g, 2019-12-05 + + ! local workspace + ! all units mks unless otherwise stated + + ! local copies of input variables + real(r8) :: q(mgncol,nlev) ! water vapor mixing ratio (kg/kg) + real(r8) :: t(mgncol,nlev) ! temperature (K) + real(r8) :: qc(mgncol,nlev) ! cloud liquid mixing ratio (kg/kg) + real(r8) :: qi(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) + real(r8) :: nc(mgncol,nlev) ! cloud liquid number concentration (1/kg) + real(r8) :: ni(mgncol,nlev) ! cloud liquid number concentration (1/kg) + real(r8) :: qr(mgncol,nlev) ! rain mixing ratio (kg/kg) + real(r8) :: qs(mgncol,nlev) ! snow mixing ratio (kg/kg) + real(r8) :: nr(mgncol,nlev) ! rain number concentration (1/kg) + real(r8) :: ns(mgncol,nlev) ! snow number concentration (1/kg) + +!--> h1g, 2019-12-06 +! temporary copies of snow and rain variables + real(r8) :: qrtmp(mgncol,nlev) ! rain mixing ratio (kg/kg) + real(r8) :: qstmp(mgncol,nlev) ! snow mixing ratio (kg/kg) + real(r8) :: nrtmp(mgncol,nlev) ! rain number concentration (1/kg) + real(r8) :: nstmp(mgncol,nlev) ! snow number concentration (1/kg) +!<-- h1g, 2019-12-06 + + ! general purpose variables + real(r8) :: deltat ! sub-time step (s) + real(r8) :: mtime ! the assumed ice nucleation timescale + + ! physical properties of the air at a given point + real(r8) :: rho(mgncol,nlev) ! density (kg m-3) + real(r8) :: dv(mgncol,nlev) ! diffusivity of water vapor + real(r8) :: mu(mgncol,nlev) ! viscosity + real(r8) :: sc(mgncol,nlev) ! schmidt number + real(r8) :: rhof(mgncol,nlev) ! density correction factor for fallspeed + + + ! cloud fractions + real(r8) :: precip_frac(mgncol,nlev) ! precip fraction assuming maximum overlap + real(r8) :: cldm(mgncol,nlev) ! cloud fraction + real(r8) :: icldm(mgncol,nlev) ! ice cloud fraction + real(r8) :: lcldm(mgncol,nlev) ! liq cloud fraction + real(r8) :: qsfm(mgncol,nlev) ! subgrid cloud water saturation scaling factor + + ! mass mixing ratios + real(r8) :: qcic(mgncol,nlev) ! in-cloud cloud liquid + real(r8) :: qiic(mgncol,nlev) ! in-cloud cloud ice + real(r8) :: qsic(mgncol,nlev) ! in-precip snow + real(r8) :: qric(mgncol,nlev) ! in-precip rain + + ! number concentrations + real(r8) :: ncic(mgncol,nlev) ! in-cloud droplet + real(r8) :: niic(mgncol,nlev) ! in-cloud cloud ice + real(r8) :: nsic(mgncol,nlev) ! in-precip snow + real(r8) :: nric(mgncol,nlev) ! in-precip rain + ! maximum allowed ni value + real(r8) :: nimax(mgncol,nlev) + + ! Size distribution parameters for: + ! cloud ice + real(r8) :: lami(mgncol,nlev) ! slope + real(r8) :: n0i(mgncol,nlev) ! intercept + ! cloud liquid + real(r8) :: lamc(mgncol,nlev) ! slope + real(r8) :: pgam(mgncol,nlev) ! spectral width parameter + ! snow + real(r8) :: lams(mgncol,nlev) ! slope + real(r8) :: n0s(mgncol,nlev) ! intercept + ! rain + real(r8) :: lamr(mgncol,nlev) ! slope + real(r8) :: n0r(mgncol,nlev) ! intercept + + ! Rates/tendencies due to: + + ! Instantaneous snow melting + real(r8) :: minstsm(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstsm(mgncol,nlev) ! number concentration + ! Instantaneous rain freezing + real(r8) :: minstrf(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstrf(mgncol,nlev) ! number concentration + + ! deposition of cloud ice + real(r8) :: vap_dep(mgncol,nlev) ! deposition from vapor to ice PMC 12/3/12 + ! sublimation of cloud ice + real(r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12 + ! ice nucleation + real(r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing + real(r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio + ! freezing of cloud water + real(r8) :: mnuccc(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccc(mgncol,nlev) ! number concentration + ! contact freezing of cloud water + real(r8) :: mnucct(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnucct(mgncol,nlev) ! number concentration + ! deposition nucleation in mixed-phase clouds (from external scheme) + real(r8) :: mnudep(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnudep(mgncol,nlev) ! number concentration + ! ice multiplication + real(r8) :: msacwi(mgncol,nlev) ! mass mixing ratio + real(r8) :: nsacwi(mgncol,nlev) ! number concentration + ! autoconversion of cloud droplets + real(r8) :: prc(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprc(mgncol,nlev) ! number concentration (rain) + real(r8) :: nprc1(mgncol,nlev) ! number concentration (cloud droplets) + ! self-aggregation of snow + real(r8) :: nsagg(mgncol,nlev) ! number concentration + ! self-collection of rain + real(r8) :: nragg(mgncol,nlev) ! number concentration + ! collection of droplets by snow + real(r8) :: psacws(mgncol,nlev) ! mass mixing ratio + real(r8) :: npsacws(mgncol,nlev) ! number concentration + ! collection of rain by snow + real(r8) :: pracs(mgncol,nlev) ! mass mixing ratio + real(r8) :: npracs(mgncol,nlev) ! number concentration + ! freezing of rain + real(r8) :: mnuccr(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccr(mgncol,nlev) ! number concentration + ! freezing of rain to form ice (mg add 4/26/13) + real(r8) :: mnuccri(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccri(mgncol,nlev) ! number concentration + ! accretion of droplets by rain + real(r8) :: pra(mgncol,nlev) ! mass mixing ratio + real(r8) :: npra(mgncol,nlev) ! number concentration + ! autoconversion of cloud ice to snow + real(r8) :: prci(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprci(mgncol,nlev) ! number concentration + ! accretion of cloud ice by snow + real(r8) :: prai(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprai(mgncol,nlev) ! number concentration + ! evaporation of rain + real(r8) :: pre(mgncol,nlev) ! mass mixing ratio + ! sublimation of snow + real(r8) :: prds(mgncol,nlev) ! mass mixing ratio + ! number evaporation + real(r8) :: nsubi(mgncol,nlev) ! cloud ice + real(r8) :: nsubc(mgncol,nlev) ! droplet + real(r8) :: nsubs(mgncol,nlev) ! snow + real(r8) :: nsubr(mgncol,nlev) ! rain + ! bergeron process + real(r8) :: berg(mgncol,nlev) ! mass mixing ratio (cloud ice) + real(r8) :: bergs(mgncol,nlev) ! mass mixing ratio (snow) + + + ! fallspeeds + ! number-weighted + real(r8) :: uns(mgncol,nlev) ! snow + real(r8) :: unr(mgncol,nlev) ! rain + ! air density corrected fallspeed parameters + real(r8) :: arn(mgncol,nlev) ! rain + real(r8) :: asn(mgncol,nlev) ! snow + real(r8) :: acn(mgncol,nlev) ! cloud droplet + real(r8) :: ain(mgncol,nlev) ! cloud ice + real(r8) :: ajn(mgncol,nlev) ! cloud small ice + + ! Mass of liquid droplets used with external heterogeneous freezing. + real(r8) :: mi0l(mgncol) + + ! saturation vapor pressures + real(r8) :: esl(mgncol,nlev) ! liquid + real(r8) :: esi(mgncol,nlev) ! ice + real(r8) :: esn ! checking for RH after rain evap + + ! saturation vapor mixing ratios + real(r8) :: qvl(mgncol,nlev) ! liquid + real(r8) :: qvi(mgncol,nlev) ! ice + real(r8) :: qvn ! checking for RH after rain evap + + ! relative humidity + real(r8) :: relhum(mgncol,nlev) + + ! parameters for cloud water and cloud ice sedimentation calculations + real(r8) :: fc(mgncol,nlev) + real(r8) :: fnc(mgncol,nlev) + real(r8) :: fi(mgncol,nlev) + real(r8) :: fni(mgncol,nlev) + + real(r8) :: fr(mgncol,nlev) + real(r8) :: fnr(mgncol,nlev) + real(r8) :: fs(mgncol,nlev) + real(r8) :: fns(mgncol,nlev) + + real(r8) :: faloutc(nlev) + real(r8) :: faloutnc(nlev) + real(r8) :: falouti(nlev) + real(r8) :: faloutni(nlev) + + real(r8) :: faloutr(nlev) + real(r8) :: faloutnr(nlev) + real(r8) :: falouts(nlev) + real(r8) :: faloutns(nlev) + + real(r8) :: faltndc + real(r8) :: faltndnc + real(r8) :: faltndi + real(r8) :: faltndni + real(r8) :: faltndqie + real(r8) :: faltndqce + + real(r8) :: faltndr + real(r8) :: faltndnr + real(r8) :: faltnds + real(r8) :: faltndns + + real(r8) :: rainrt(mgncol,nlev) ! rain rate for reflectivity calculation + + ! dummy variables + real(r8) :: dum + real(r8) :: dum1 + real(r8) :: dum2 + real(r8) :: dumni0 + real(r8) :: dumns0 + ! dummies for checking RH + real(r8) :: qtmp + real(r8) :: ttmp + ! dummies for conservation check + real(r8) :: ratio + real(r8) :: tmpfrz + ! dummies for in-cloud variables + real(r8) :: dumc(mgncol,nlev) ! qc + real(r8) :: dumnc(mgncol,nlev) ! nc + real(r8) :: dumi(mgncol,nlev) ! qi + real(r8) :: dumni(mgncol,nlev) ! ni + real(r8) :: dumr(mgncol,nlev) ! rain mixing ratio + real(r8) :: dumnr(mgncol,nlev) ! rain number concentration + real(r8) :: dums(mgncol,nlev) ! snow mixing ratio + real(r8) :: dumns(mgncol,nlev) ! snow number concentration + ! Array dummy variable + real(r8) :: dum_2D(mgncol,nlev) + real(r8) :: pdel_inv(mgncol,nlev) + + ! loop array variables + ! "i" and "k" are column/level iterators for internal (MG) variables + ! "n" is used for other looping (currently just sedimentation) + integer i, k, n, it + + ! number of sub-steps for loops over "n" (for sedimentation) + integer nstep + integer mdust + + ! Varaibles to scale fall velocity between small and regular ice regimes. + real(r8) :: irad + real(r8) :: ifrac + + real(r8) :: tnd_qsnow(mgncol,nlev) ! snow mass tendency (kg/kg/s) + real(r8) :: tnd_nsnow(mgncol,nlev) ! snow number tendency (#/kg/s) + real(r8) :: re_ice(mgncol,nlev) ! ice effective radius (m) + + ! From external ice nucleation. + real(r8) :: frzimm(mgncol,nlev) ! Number tendency due to immersion freezing (1/cm3) + real(r8) :: frzcnt(mgncol,nlev) ! Number tendency due to contact freezing (1/cm3) + real(r8) :: frzdep(mgncol,nlev) ! Number tendency due to deposition nucleation (1/cm3) + + real(r8) :: lflx(mgncol,nlev+1) ! grid-box average liquid condensate flux (kg m^-2 s^-1) + real(r8) :: iflx(mgncol,nlev+1) ! grid-box average ice condensate flux (kg m^-2 s^-1) + + real(r8) :: qcsinksum_rate1ord(mgncol,nlev) ! 1st order rate for direct cw to precip conversion + + real(r8) :: effc(mgncol,nlev) ! droplet effective radius (micron) + real(r8) :: effc_fn(mgncol,nlev) ! droplet effective radius, assuming nc = 1.e8 kg-1 + real(r8) :: effi(mgncol,nlev) ! cloud ice effective radius (micron) + real(r8) :: sadice(mgncol,nlev) ! cloud ice surface area density (cm2/cm3) + real(r8) :: sadsnow(mgncol,nlev) ! cloud snow surface area density (cm2/cm3) + + real(r8) :: nevapr(mgncol,nlev) ! evaporation rate of rain + snow (1/s) + real(r8) :: evapsnow(mgncol,nlev) ! sublimation rate of snow (1/s) + real(r8) :: am_evp_st(mgncol,nlev) ! stratiform evaporation area (frac) + real(r8) :: prain(mgncol,nlev) ! production of rain + snow (1/s) + real(r8) :: prodsnow(mgncol,nlev) ! production of snow (1/s) + real(r8) :: cmeout(mgncol,nlev) ! evap/sub of cloud (1/s) + real(r8) :: deffi(mgncol,nlev) ! ice effective diameter for optics (radiation) (micron) + real(r8) :: pgamrad(mgncol,nlev) ! ice gamma parameter for optics (radiation) (no units) + real(r8) :: lamcrad(mgncol,nlev) ! slope of droplet distribution for optics (radiation) (1/m) + + real(r8) :: dsout(mgncol,nlev) ! snow diameter (m) + + real(r8) :: qcsevap(mgncol,nlev) ! cloud water evaporation due to sedimentation (1/s) + real(r8) :: qisevap(mgncol,nlev) ! cloud ice sublimation due to sublimation (1/s) + real(r8) :: qvres(mgncol,nlev) ! residual condensation term to ensure RH < 100% (1/s) + + real(r8) :: cmeitot(mgncol,nlev) ! grid-mean cloud ice sub/dep (1/s) + real(r8) :: vtrmc(mgncol,nlev) ! mass-weighted cloud water fallspeed (m/s) + real(r8) :: vtrmi(mgncol,nlev) ! mass-weighted cloud ice fallspeed (m/s) + real(r8) :: umr(mgncol,nlev) ! mass weighted rain fallspeed (m/s) + real(r8) :: ums(mgncol,nlev) ! mass weighted snow fallspeed (m/s) + real(r8) :: qcsedten(mgncol,nlev) ! qc sedimentation tendency (1/s) + real(r8) :: qisedten(mgncol,nlev) ! qi sedimentation tendency (1/s) + real(r8) :: qrsedten(mgncol,nlev) ! qr sedimentation tendency (1/s) + real(r8) :: qssedten(mgncol,nlev) ! qs sedimentation tendency (1/s) + + real(r8) :: pratot(mgncol,nlev) ! accretion of cloud by rain + real(r8) :: prctot(mgncol,nlev) ! autoconversion of cloud to rain + real(r8) :: mnuccctot(mgncol,nlev) ! mixing ratio tend due to immersion freezing + real(r8) :: mnuccttot(mgncol,nlev) ! mixing ratio tend due to contact freezing + real(r8) :: msacwitot(mgncol,nlev) ! mixing ratio tend due to H-M splintering + real(r8) :: psacwstot(mgncol,nlev) ! collection of cloud water by snow + real(r8) :: bergstot(mgncol,nlev) ! bergeron process on snow + real(r8) :: bergtot(mgncol,nlev) ! bergeron process on cloud ice + real(r8) :: melttot(mgncol,nlev) ! melting of cloud ice + real(r8) :: homotot(mgncol,nlev) ! homogeneous freezing cloud water + + real(r8) :: qcrestot(mgncol,nlev) ! residual cloud condensation due to removal of excess supersat + real(r8) :: prcitot(mgncol,nlev) ! autoconversion of cloud ice to snow + real(r8) :: praitot(mgncol,nlev) ! accretion of cloud ice by snow + real(r8) :: qirestot(mgncol,nlev) ! residual ice deposition due to removal of excess supersat + real(r8) :: mnuccrtot(mgncol,nlev) ! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s1) + real(r8) :: mnuccritot(mgncol,nlev) ! mixing ratio tendency due to heterogeneous freezing of rain to ice for small rain drops (1/s1) + real(r8) :: pracstot(mgncol,nlev) ! mixing ratio tendency due to accretion of rain by snow (1/s) + real(r8) :: mnuccdtot(mgncol,nlev) ! mass tendency from ice nucleation + real(r8) :: meltsdttot(mgncol,nlev) ! latent heating rate due to melting of snow (W/kg) + real(r8) :: frzrdttot(mgncol,nlev) ! latent heating rate due to homogeneous freezing of rain (W/kg) + real(r8) :: nrout(mgncol,nlev) ! rain number concentration (1/m3) + real(r8) :: nsout(mgncol,nlev) ! snow number concentration (1/m3) + real(r8) :: refl(mgncol,nlev) ! analytic radar reflectivity + real(r8) :: arefl(mgncol,nlev) ! average reflectivity will zero points outside valid range + real(r8) :: areflz(mgncol,nlev) ! average reflectivity in z. + real(r8) :: frefl(mgncol,nlev) ! fractional occurrence of radar reflectivity + real(r8) :: csrfl(mgncol,nlev) ! cloudsat reflectivity + real(r8) :: acsrfl(mgncol,nlev) ! cloudsat average + real(r8) :: fcsrfl(mgncol,nlev) ! cloudsat fractional occurrence of radar reflectivity + real(r8) :: rercld(mgncol,nlev) ! effective radius calculation for rain + cloud + real(r8) :: ncai(mgncol,nlev) ! output number conc of ice nuclei available (1/m3) + real(r8) :: ncal(mgncol,nlev) ! output number conc of CCN (1/m3) + real(r8) :: qrout2(mgncol,nlev) ! copy of qrout as used to compute drout2 + real(r8) :: qsout2(mgncol,nlev) ! copy of qsout as used to compute dsout2 + real(r8) :: nrout2(mgncol,nlev) ! copy of nrout as used to compute drout2 + real(r8) :: nsout2(mgncol,nlev) ! copy of nsout as used to compute dsout2 + real(r8) :: drout2(mgncol,nlev) ! mean rain particle diameter (m) + real(r8) :: dsout2(mgncol,nlev) ! mean snow particle diameter (m) + real(r8) :: freqs(mgncol,nlev) ! fractional occurrence of snow + real(r8) :: freqr(mgncol,nlev) ! fractional occurrence of rain + real(r8) :: nfice(mgncol,nlev) ! fractional occurrence of ice + real(r8) :: qcrat(mgncol,nlev) ! limiter for qc process rates (1=no limit --> 0. no qc) + + real(r8) :: sum_freeze(mgncol,nlev) + real(r8) :: sum_freeze2(mgncol,nlev) + real(r8) :: sum_rime(mgncol,nlev) + real(r8) :: sum_splinter(mgncol,nlev) + real(r8) :: sum_bergs(mgncol,nlev) + real(r8) :: sum_cond(mgncol,nlev) + real(r8) :: sum_berg(mgncol,nlev) + real(r8) :: sum_ice_adj(mgncol,nlev) + real(r8) :: qldt_sum + +! these variables are only used in the GFDL implementation + + real(r8) :: cmelo(mgncol,nlev) ! liquid condensation + real(r8) :: eroslo(mgncol,nlev) ! liquid erosion + real(r8) :: erosio(mgncol,nlev) ! ice erosion + real(r8) :: preo(mgncol,nlev) ! rain evaporation + real(r8) :: prdso(mgncol,nlev) ! snow sublimation + real(r8) :: npccn2(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) + logical :: do_berg1 + logical :: limit_berg = .false. + real(r8) :: berg_lim = 1.0e-6_r8 + real(r8) :: dum3 ! temporary dummy variable + + +! droplet number + real(r8) :: nucclim(mgncol,nlev) + real(r8) :: nucclimo(mgncol,nlev) + real(r8) :: npccno(mgncol,nlev) + real(r8) :: nnuccco(mgncol,nlev) + real(r8) :: nnuccto(mgncol,nlev) + real(r8) :: npsacwso(mgncol,nlev) + real(r8) :: nsubco(mgncol,nlev) + real(r8) :: nerosco(mgncol,nlev) + real(r8) :: nprao(mgncol,nlev) + real(r8) :: nprc1o(mgncol,nlev) + +! cloud ice number + real(r8) :: nucclim1i(mgncol,nlev) + real(r8) :: nucclim1io(mgncol,nlev) + real(r8) :: nnuccdo(mgncol,nlev) + real(r8) :: nsacwio(mgncol,nlev) + real(r8) :: nsubio(mgncol,nlev) + real(r8) :: nerosio(mgncol,nlev) + real(r8) :: nprcio(mgncol,nlev) + real(r8) :: npraio(mgncol,nlev) + real(r8) :: nnuccrio(mgncol,nlev) + +#ifdef GFDL_COMPATIBLE_MICROP + real(r8) :: dum2i(mgncol,nlev) ! used with ice nuleation + real(r8) :: dum2l(mgncol,nlev) ! used with drop nuleation + real(r8) :: dum2a(mgncol,nlev) ! used with ice nuleation +#endif + + real(r8) :: flx(nlev), precip, dum_1D(nlev) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! default return error message + errstring = ' ' + + ! Process inputs + + ! assign variable deltat for sub-stepping... + deltat = deltatin + + + ! Copies of input concentrations that may be changed internally. + + t = tn + q = qn + qc = qcn + nc = ncn + qi = qin + ni = nin + qr = qrn + nr = nrn + qs = qsn + ns = nsn + + frzimm = 0.0_r8 + frzcnt = 0.0_r8 + frzdep = 0.0_r8 + + tnd_qsnow = 0.0_r8 + tnd_nsnow = 0.0_r8 + re_ice = 20e-6 + + ssat_disposal = 0.0_r8 + sum_freeze = 0.0_r8 + sum_freeze2 = 0.0_r8 + + ! cldn: used to set cldm, unused for subcolumns + ! liqcldf: used to set lcldm, unused for subcolumns + ! icecldf: used to set icldm, unused for subcolumns + + if (microp_uniform) then + ! subcolumns, set cloud fraction variables to one + ! if cloud water or ice is present, if not present + ! set to mincld (mincld used instead of zero, to prevent + ! possible division by zero errors). + + where (qc >= qsmall) + lcldm = 1._r8 + elsewhere + lcldm = mincld + end where + + where (qi >= qsmall) + icldm = 1._r8 + elsewhere + icldm = mincld + end where + + cldm = max(icldm, lcldm) + qsfm = 1._r8 + + else + ! get cloud fraction, check for minimum + cldm = max(cldn,mincld) + lcldm = max(liqcldf,mincld) + icldm = max(icecldf,mincld) + qsfm = 1.0_r8 + end if + + ! Initialize local variables + + ! local physical properties + rho = p/(r*t) + dv = 8.794E-5_r8 * t**1.81_r8 / p + mu = 1.496E-6_r8 * t**1.5_r8 / (t + 120._r8) + sc = mu/(rho*dv) + + + ! air density adjustment for fallspeed parameters + ! includes air density correction factor to the + ! power of 0.54 following Heymsfield and Bansemer 2007 + + rhof=(rhosu/rho)**0.54_r8 +#ifdef GFDL_COMPATIBLE_MICROP + if (.not. rho_factor_in_max_vt) rhof = 1.0 + rhof = MIN (rhof, max_rho_factor_in_vt) +#endif + +! --->h1g, add namelist variables, 2014-07-01 +! Zhao et al., ACP 2013, Table 1, +! ai: 350-1400 (s^-1); as: 5.86-23.44 (m^0.59 s^-1) +! IceFallFac: 0.5 -- 2; SnowFallFac: 0.5 -- 2 + arn=ar*rhof + asn=as* SnowFallFac* rhof + acn=g*rhow/(18._r8*mu) + ain=ai * IceFallFac*(rhosu/rho)**0.35_r8 + ajn=aj * (rhosu/rho)**0.35_r8 + + diag_4l(:,j,:,diag_pt%qidt_tiny) = 0.0 + diag_4l(:,j,:,diag_pt%qnidt_tiny) = 0.0 + diag_4l(:,j,:,diag_pt%qrdt_tiny) = 0.0 + diag_4l(:,j,:,diag_pt%qnrdt_tiny) = 0.0 + + diag_4l(:,j,:,diag_pt%qldt_tiny) = 0.0 + diag_4l(:,j,:,diag_pt%qndt_tiny) = 0.0 + diag_4l(:,j,:,diag_pt%qsdt_tiny) = 0.0 + diag_4l(:,j,:,diag_pt%qnsdt_tiny) = 0.0 + + + !INITIALIZE STUFF FOR SUBSTEPPING + !=============================================== + +!--> h1g, 2019-12-05 + ! get sub-step time step + deltat=deltat/real(iter) +!<-- h1g, 2019-12-05 + + ! set mtime here to avoid answer-changing + mtime=deltat + + ! initialize tendencies to zero +!--> h1g, 2019-12-05 + tlat1 = 0._r8 + qvlat1 = 0._r8 + qctend1 = 0._r8 + qitend1 = 0._r8 + nctend1 = 0._r8 + nitend1 = 0._r8 + qrtend1 = 0._r8 + qstend1 = 0._r8 + nrtend1 = 0._r8 + nstend1 = 0._r8 +!<-- h1g, 2019-12-05 + + ! initialize microphysics output + qcsevap=0._r8 + qisevap=0._r8 + qvres =0._r8 + cmeitot =0._r8 + vtrmc =0._r8 + vtrmi =0._r8 + qcsedten =0._r8 + qisedten =0._r8 + qrsedten =0._r8 + qssedten =0._r8 + + diag_4l(:,j,:,diag_pt%qndt_sedi) = 0.0 + diag_4l(:,j,:,diag_pt%qnidt_sedi) = 0.0 + diag_4l(:,j,:,diag_pt%rain_num_sedi) = 0.0 + diag_4l(:,j,:,diag_pt%snow_num_sedi) = 0.0 + +!initialize gfdl-only arrays-- this may not be needed and will be reviewed later. + preo =0._r8 + prdso=0._r8 + cmelo =0._r8 + eroslo =0._r8 + erosio =0._r8 +!droplet number + nucclimo = 0._r8 + npccno = 0._r8 + nnuccco = 0._r8 + nnuccto = 0._r8 + npsacwso = 0._r8 + nsubco = 0._r8 + nerosco = 0._r8 + nprao = 0._r8 + nprc1o = 0._r8 +!ice number + nucclim1io = 0._r8 + nnuccdo = 0._r8 + nsacwio = 0._r8 + nsubio = 0._r8 + nerosio = 0._r8 + nprcio = 0._r8 + npraio = 0._r8 + nnuccrio = 0._r8 + + pratot=0._r8 + prctot=0._r8 + mnuccctot=0._r8 + mnuccttot=0._r8 + msacwitot=0._r8 + psacwstot=0._r8 + bergstot=0._r8 + bergtot=0._r8 + melttot=0._r8 + homotot=0._r8 + qcrestot=0._r8 + prcitot=0._r8 + praitot=0._r8 + qirestot=0._r8 + mnuccrtot=0._r8 + mnuccritot=0._r8 + pracstot=0._r8 + meltsdttot=0._r8 + frzrdttot=0._r8 + mnuccdtot=0._r8 + + rflx=0._r8 + sflx=0._r8 + lflx=0._r8 + iflx=0._r8 + + ! initialize precip output + + qrout=0._r8 + qsout=0._r8 + nrout=0._r8 + nsout=0._r8 + + ! for refl calc + rainrt = 0._r8 + + ! initialize rain size + rercld=0._r8 + + qcsinksum_rate1ord = 0._r8 + + ! initialize variables for trop_mozart + nevapr = 0._r8 + evapsnow = 0._r8 + am_evp_st = 0._r8 + prain = 0._r8 + prodsnow = 0._r8 + cmeout = 0._r8 + + precip_frac = mincld + + lamc=0._r8 + + !*********DO SUBSTEPPING!*************** + !============================================ + substepping: do it=1,iter + + ! initialize sub-step microphysical tendencies + + tlat=0._r8 + qvlat=0._r8 + qctend=0._r8 + qitend=0._r8 + qstend = 0._r8 + qrtend = 0._r8 + nctend=0._r8 + nitend=0._r8 + nrtend = 0._r8 + nstend = 0._r8 + + ! initialize in-cloud and in-precip quantities to zero + qcic = 0._r8 + qiic = 0._r8 + qsic = 0._r8 + qric = 0._r8 + + ncic = 0._r8 + niic = 0._r8 + nsic = 0._r8 + nric = 0._r8 + + ! initialize precip at surface + + prect = 0._r8 + preci = 0._r8 + + ! initialize precip fallspeeds to zero + ums = 0._r8 + uns = 0._r8 + umr = 0._r8 + unr = 0._r8 + + ! initialize limiter for output + qcrat = 1._r8 + + ! Many outputs have to be initialized here at the top to work around + ! ifort problems, even if they are always overwritten later. + effc = 10._r8 + lamcrad = 0._r8 + pgamrad = 0._r8 + effc_fn = 10._r8 + effi = 25._r8 + sadice = 0._r8 + sadsnow = 0._r8 + deffi = 50._r8 + + qrout2 = 0._r8 + nrout2 = 0._r8 + drout2 = 0._r8 + qsout2 = 0._r8 + nsout2 = 0._r8 + dsout = 0._r8 + dsout2 = 0._r8 + + freqr = 0._r8 + freqs = 0._r8 + + reff_rain = 0._r8 + reff_snow = 0._r8 + + refl = -9999._r8 + arefl = 0._r8 + areflz = 0._r8 + frefl = 0._r8 + csrfl = 0._r8 + acsrfl = 0._r8 + fcsrfl = 0._r8 + + ncal = 0._r8 + ncai = 0._r8 + + nfice = 0._r8 + +!--> h1g, 2019-12-06 +! re-calculate saturation vapor pressure for liquid and ice + do k = 1, nlev + do i = 1, mgncol + call compute_qs (t(i,k), p(i,k), qvl(i,k), q = q(i,k), & + esat = esl(i,k), es_over_liq = .true.) + call compute_qs (t(i,k), p(i,k), qvi(i,k), q = q(i,k), & + esat = esi(i,k), es_over_liq_and_ice = .true.) + + if ( t(i,k) < tmelt) then + ! Scale the water saturation values to reflect subgrid scale + ! ice cloud fraction, where ice clouds begin forming at a + ! gridbox average relative humidity of rhmini (not 1). + ! + ! NOTE: For subcolumns and other non-subgrid clouds, qsfm willi + ! be 1. + qvi(i,k) = qsfm(i,k) * qvi(i,k) + esi(i,k) = qsfm(i,k) * esi(i,k) + qvl(i,k) = qsfm(i,k) * qvl(i,k) + esl(i,k) = qsfm(i,k) * esl(i,k) + endif + end do + end do + + relhum = q / max(qvl, qsmall) +!<-- h1g, 2019-12-06 + +#ifdef GFDL_COMPATIBLE_MICROP +! --->h1g, 2019-10-25 + dum_30 = 5.0_r8*exp(0.304_r8*( 30.0)) + dum_5 = 5.0_r8*exp(0.304_r8*( 5.0)) +! <---h1g, 2019-10-25 + +! calculate ice nucleation dum2i + do k=1,nlev + do i=1,mgncol + if (t(i,k).lt. icenuct ) then + + if ( liu_in .or. use_Fan2019 ) then + dum2i(i,k) = naai(i,k) + if ( lat(i)*180.0/3.14159 > 60.0 ) dum2i(i,k) = dum2i(i,k) * ice_nucl_factor ! h1g, 2019-12-17 + +! --->h1g, 2014-05-30 add Meyers ice nucleation formula (Only temperature dependent) + elseif ( use_Meyers ) then + dum2i(i,k) = (exp(12.96* (tmelt -t(i,k))/80 - 0.639)) *1000._r8 + dum2i(i,k)= ( dum2i(i,k) )/rho(i,k) ! convert from m-3 to kg-1 +! <--- h1g, 2014-05-30 + +! <-- h1g, 2020-04-18 + elseif ( use_FanAndCooper ) then + dum2i(i,k) = 2.74 * concen_dust_sub(i,k) * exp(0.412_r8*(tmelt-t(i,k))) + dum2i(i,k) = min( dum2i(i,k), Nice_max_Fan*1000._r8 ) + dum2i(i,k) = dum2i(i,k) * p(i,k)/ 95000. + dum2i(i,k)= dum2i(i,k)/rho(i,k) ! convert from m-3 to kg-1 + + dum_tmp = 0.005_r8*exp(0.304_r8*(tmelt-t(i,k)))*1000._r8 + dum_tmp = min( dum_tmp, 5.0_r8*exp(0.304_r8*(-tc_cooper))) + dum_tmp = dum_tmp/rho(i,k) ! convert from m-3 to kg-1 + dum2i(i,k)= dum2i(i,k) + dum_tmp +! --> h1g, 2020-04-18 + + else +! cooper curve (factor of 1000 is to convert from L-1 to m-3) + dum2i(i,k)=0.005_r8*exp(0.304_r8*(tmelt-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),5.0_r8*exp(0.304_r8*(-tc_cooper))) + +! --->h1g, 2019-10-25 + dum_tmp = dum_5 + (dum_30-dum_5)/25.0*( tmelt-t(i,k) - 5.0) + if ( do_Ni_linear_interp ) & + dum2i(i,k)= max(dum2i(i,k), dum_tmp ) +! <---h1g, 2019-10-25 + + dum2i(i,k)=dum2i(i,k)/rho(i,k) ! convert from m-3 to kg-1 + endif + else + dum2i(i,k)=0._r8 + end if ! t(i,k).lt. icenuct + ! naai(i,k) = dum2i(i,k) + end do + end do +#endif + + +#ifdef GFDL_COMPATIBLE_MICROP + dum2l = 0. +#endif + +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! droplet activation +#ifdef GFDL_COMPATIBLE_MICROP + do k=1,nlev + do i=1,mgncol + if ( qc(i,k).ge.qsmall ) then + dum2l(i,k) = max(0._r8, npccn (i,k)) + +!RSH npccn2 is the change in droplet number on this step. In the +! non-GFDL_COMPATIBLE_MICROP, this is not calculated since the input +! droplet number already includes the newly activated droplets. + npccn2(i,k) = ((dum2l(i,k) - nc(i,k)/cldm(i,k))/tau_act_liq )*cldm(i,k) + npccn2(i,k) = max(0._r8,npccn2(i,k)) + else + npccn2(i,k)=0._r8 + end if + ! nc(i,k) = nc(i,k)+npccn2(i,k)*deltat ! from MG2, additional changes from h1g + end do + end do +#endif + +! ice activation + if (do_cldice) then +! --->h1g, 2014-05-30 add Meyers ice nucleation option + where (dum2i > 0._r8 .and. t < icenuct .and. & + relhum*esl/esi > rhmini+0.05_r8 .and. icldm > icld_cri) + + !if NAAI > 0. then set numice = naai (as before) + !note: this is gridbox averaged + nnuccd = (dum2i-ni/icldm)/tau_act_ice * icldm + nnuccd = max(nnuccd,0._r8) + nimax = dum2i*icldm + !Calc mass of new particles using new crystal mass... + !also this will be multiplied by mtime as nnuccd is... + mnuccd = nnuccd * mi0 + + elsewhere + nnuccd = 0._r8 + nimax = 0._r8 + mnuccd = 0._r8 + end where + ! ni = ni + nnuccd*deltat ! h1g, 2019-12-10 + end if ! do_cldice + + !============================================================================= +!--> h1g, 2019-12-06 +! temporary copy of qs, ns, qr, nr for calculating qs, ns, qr, nr tendencies + qstmp = qs + nstmp = ns + qrtmp = qr + nrtmp = nr +!<-- h1g, 2019-12-06 + + do k=1,nlev + do i=1,mgncol + + ! calculate instantaneous precip processes (melting and homogeneous freezing) + + ! melting of snow at +2 C + + if (t(i,k) > snowmelt) then + if (qs(i,k) > 0._r8) then + + ! make sure melting snow doesn't reduce temperature below threshold + dum = -xlf/cpp*qs(i,k) + if (t(i,k)+dum < snowmelt) then + dum = (t(i,k)-snowmelt)*cpp/xlf + dum = dum/qs(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + minstsm(i,k) = dum*qs(i,k) + ninstsm(i,k) = dum*ns(i,k) + + dum1=-xlf*minstsm(i,k)/deltat + tlat(i,k)=tlat(i,k)+dum1 + meltsdttot(i,k)=meltsdttot(i,k) + dum1 + + qs(i,k) = max(qs(i,k) - minstsm(i,k), 0._r8) + ns(i,k) = max(ns(i,k) - ninstsm(i,k), 0._r8) + qr(i,k) = max(qr(i,k) + minstsm(i,k), 0._r8) + nr(i,k) = max(nr(i,k) + ninstsm(i,k), 0._r8) + end if + end if + + end do + end do + + + do k=1,nlev + do i=1,mgncol + ! freezing of rain at -5 C + + if (t(i,k) < rainfrze) then + + if (qr(i,k) > 0._r8) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = xlf/cpp*qr(i,k) + if (t(i,k)+dum > rainfrze) then + dum = -(t(i,k)-rainfrze)*cpp/xlf + dum = dum/qr(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + minstrf(i,k) = dum*qr(i,k) + ninstrf(i,k) = dum*nr(i,k) + + ! heating tendency + dum1 = xlf*minstrf(i,k)/deltat + tlat(i,k)=tlat(i,k)+dum1 + frzrdttot(i,k)=frzrdttot(i,k) + dum1 + + qr(i,k) = max(qr(i,k) - minstrf(i,k), 0._r8) + nr(i,k) = max(nr(i,k) - ninstrf(i,k), 0._r8) + qs(i,k) = max(qs(i,k) + minstrf(i,k), 0._r8) + ns(i,k) = max(ns(i,k) + ninstrf(i,k), 0._r8) + + end if + end if + end do + end do + + + do k=1,nlev + do i=1,mgncol + ! obtain in-cloud values of cloud water/ice mixing ratios and number concentrations + !------------------------------------------------------- + ! for microphysical process calculations + ! units are kg/kg for mixing ratio, 1/kg for number conc + + if (qc(i,k).ge.qsmall) then + ! limit in-cloud values to 0.005 kg/kg + qcic(i,k)=min(qc(i,k)/lcldm(i,k),5.e-3_r8) + ncic(i,k)=max(nc(i,k)/lcldm(i,k),0._r8) + + ! specify droplet concentration + if (nccons) then + ncic(i,k)=ncnst/rho(i,k) + end if + else + qcic(i,k)=0._r8 + ncic(i,k)=0._r8 + end if + + if (qi(i,k).ge.qsmall) then + ! limit in-cloud values to 0.005 kg/kg + qiic(i,k)=min(qi(i,k)/icldm(i,k),5.e-3_r8) + niic(i,k)=max( ( ni(i,k) +nnuccd(i,k)*deltat )/icldm(i,k),0._r8) ! h1g, 2019-12-10 + ! niic(i,k)=max( ni(i,k)/icldm(i,k),0._r8) ! h1g, 2019-12-10 + + ! switch for specification of cloud ice number + if (nicons) then + niic(i,k)=ninst/rho(i,k) + end if + else + qiic(i,k)=0._r8 + niic(i,k)=0._r8 + end if + + end do + end do + + !======================================================================== + + ! for sub-columns cldm has already been set to 1 if cloud + ! water or ice is present, so precip_frac will be correctly set below + ! and nothing extra needs to be done here + + precip_frac = cldm + + micro_vert_loop: do k=1,nlev + + if (trim(micro_mg_precip_frac_method) == 'in_cloud') then + + if (k /= 1) then + where (qc(:,k) < qsmall .and. qi(:,k) < qsmall) + precip_frac(:,k) = precip_frac(:,k-1) + end where + endif + + else if (trim(micro_mg_precip_frac_method) == 'max_overlap') then + + ! calculate precip fraction based on maximum overlap assumption + + ! if rain or snow mix ratios are smaller than threshold, + ! then leave precip_frac as cloud fraction at current level + if (k /= 1) then + where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall) + precip_frac(:,k)=max(precip_frac(:,k-1),precip_frac(:,k)) + end where + end if + + endif + + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! get size distribution parameters based on in-cloud cloud water + ! these calculations also ensure consistency between number and mixing ratio + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! cloud liquid + !------------------------------------------- + call size_dist_param_liq(mg_liq_props, qcic(:,k), ncic(:,k), rho(:,k), & + pgam(:,k), lamc(:,k), mgncol) + + !======================================================================== + ! autoconversion of cloud liquid water to rain + ! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc + ! minimum qc of 1 x 10^-8 prevents floating point error + + if (.not. do_sb_physics .and. .not.do_cotton_auto) then + call kk2000_liq_autoconversion(microp_uniform, qcic(:,k), & + ncic(:,k), rho(:,k), relvar(:,k), prc(:,k), nprc(:,k), nprc1(:,k), mgncol) + endif + + ! assign qric based on prognostic qr, using assumed precip fraction + ! note: this could be moved above for consistency with qcic and qiic calculations + qric(:,k) = qr(:,k)/precip_frac(:,k) + nric(:,k) = nr(:,k)/precip_frac(:,k) + + ! limit in-precip mixing ratios to 10 g/kg + qric(:,k)=min(qric(:,k),0.01_r8) + + ! add autoconversion to precip from above to get provisional rain mixing ratio + ! and number concentration (qric and nric) + + where (qric(:,k).lt.qsmall) + qric(:,k)=0._r8 + nric(:,k)=0._r8 + end where + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + nric(:,k)=max(nric(:,k),0._r8) + + ! Get size distribution parameters for cloud ice + + call size_dist_param_basic(mg_ice_props, qiic(:,k), niic(:,k), & + lami(:,k), mgncol, n0=n0i(:,k)) + + ! Alternative autoconversion + if (do_cotton_auto ) then + call cotton_liq_autoconversion(.false., qcic(:,k), & + ncic(:,k), rho(:,k), relvar(:,k), rthresh, prc(:,k), nprc(:,k), nprc1(:,k), mgncol) + elseif (do_sb_physics) then + call sb2001v2_liq_autoconversion(pgam(:,k),qcic(:,k),ncic(:,k), & + qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k), mgncol) + endif + + + !....................................................................... + ! Autoconversion of cloud ice to snow + ! similar to Ferrier (1994) + + if (do_cldice) then + call ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), & + dcs, prci(:,k), nprci(:,k), mgncol) + + else + ! Add in the particles that we have already converted to snow, and + ! don't do any further autoconversion of ice. + prci(:,k) = tnd_qsnow(:,k) / cldm(:,k) + nprci(:,k) = tnd_nsnow(:,k) / cldm(:,k) + end if + + ! note, currently we don't have this + ! inside the do_cldice block, should be changed later + ! assign qsic based on prognostic qs, using assumed precip fraction + qsic(:,k) = qs(:,k)/precip_frac(:,k) + nsic(:,k) = ns(:,k)/precip_frac(:,k) + + ! limit in-precip mixing ratios to 10 g/kg + qsic(:,k)=min(qsic(:,k),0.01_r8) + + ! if precip mix ratio is zero so should number concentration + + where (qsic(:,k) < qsmall) + qsic(:,k)=0._r8 + nsic(:,k)=0._r8 + end where + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + nsic(:,k)=max(nsic(:,k),0._r8) + !....................................................................... + ! get size distribution parameters for precip + !...................................................................... + ! rain + + call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), & + lamr(:,k), mgncol, n0=n0r(:,k)) + + where (lamr(:,k) >= qsmall) + + ! provisional rain number and mass weighted mean fallspeed (m/s) + + unr(:,k) = min(arn(:,k)*gamma_br_plus1/lamr(:,k)**br,9.1_r8*rhof(:,k)) + umr(:,k) = min(arn(:,k)*gamma_br_plus4/(6._r8*lamr(:,k)**br),9.1_r8*rhof(:,k)) + + elsewhere + umr(:,k) = 0._r8 + unr(:,k) = 0._r8 + end where + + !...................................................................... + ! snow + + call size_dist_param_basic(mg_snow_props, qsic(:,k), nsic(:,k), & + lams(:,k), mgncol, n0=n0s(:,k)) + + where (lams(:,k) > 0._r8) + ! provisional snow number and mass weighted mean fallspeed (m/s) + ums(:,k) = min(asn(:,k)*gamma_bs_plus4/(6._r8*lams(:,k)**bs),1.2_r8*rhof(:,k)) + uns(:,k) = min(asn(:,k)*gamma_bs_plus1/lams(:,k)**bs,1.2_r8*rhof(:,k)) + + elsewhere + ums(:,k) = 0._r8 + uns(:,k) = 0._r8 + end where + + if (do_cldice) then + if (.not. use_hetfrz_classnuc) then + + ! heterogeneous freezing of cloud water + !---------------------------------------------- + + call immersion_freezing(microp_uniform, t(:,k), pgam(:,k), lamc(:,k), & + qcic(:,k), ncic(:,k), relvar(:,k), mnuccc(:,k), nnuccc(:,k), mgncol) + + + ! make sure number of droplets frozen does not exceed available ice nuclei concentration + ! this prevents 'runaway' droplet freezing + + where (qcic(:,k).ge.qsmall .and. t(:,k).lt.269.15_r8) + where (nnuccc(:,k)*lcldm(:,k).gt.nnuccd(:,k)) + ! scale mixing ratio of droplet freezing with limit + mnuccc(:,k)=mnuccc(:,k)*(nnuccd(:,k)/(nnuccc(:,k)*lcldm(:,k))) + nnuccc(:,k)=nnuccd(:,k)/lcldm(:,k) + end where + end where + + mdust = size(rndst,3) + call contact_freezing(microp_uniform, t(:,k), p(:,k), rndst(:,k,:), & + nacon(:,k,:), pgam(:,k), lamc(:,k), qcic(:,k), ncic(:,k), & + relvar(:,k), mnucct(:,k), nnucct(:,k), mgncol, mdust) + + mnudep(:,k)=0._r8 + nnudep(:,k)=0._r8 + else + + ! Mass of droplets frozen is the average droplet mass, except + ! with two limiters: concentration must be at least 1/cm^3, and + ! mass must be at least the minimum defined above. + mi0l = qcic(:,k)/max(ncic(:,k), 1.0e6_r8/rho(:,k)) + mi0l = max(mi0l_min, mi0l) + + where (qcic(:,k) >= qsmall) + nnuccc(:,k) = frzimm(:,k)*1.0e6_r8/rho(:,k) + mnuccc(:,k) = nnuccc(:,k)*mi0l + + nnucct(:,k) = frzcnt(:,k)*1.0e6_r8/rho(:,k) + mnucct(:,k) = nnucct(:,k)*mi0l + + nnudep(:,k) = frzdep(:,k)*1.0e6_r8/rho(:,k) + mnudep(:,k) = nnudep(:,k)*mi0 + elsewhere + nnuccc(:,k) = 0._r8 + mnuccc(:,k) = 0._r8 + + nnucct(:,k) = 0._r8 + mnucct(:,k) = 0._r8 + + nnudep(:,k) = 0._r8 + mnudep(:,k) = 0._r8 + end where + + end if + + else + mnuccc(:,k)=0._r8 + nnuccc(:,k)=0._r8 + mnucct(:,k)=0._r8 + nnucct(:,k)=0._r8 + mnudep(:,k)=0._r8 + nnudep(:,k)=0._r8 + end if + + call snow_self_aggregation(t(:,k), rho(:,k), asn(:,k), rhosn, qsic(:,k), nsic(:,k), & + nsagg(:,k), mgncol) + + call accrete_cloud_water_snow(t(:,k), rho(:,k), asn(:,k), uns(:,k), mu(:,k), & + qcic(:,k), ncic(:,k), qsic(:,k), pgam(:,k), lamc(:,k), lams(:,k), n0s(:,k), & + psacws(:,k), npsacws(:,k), use_const_ELI, ELI_RK, mgncol) ! h1g, 2020-04-16 + if ( .not. do_liq_num_riming ) npsacws(:,k) = 0.0 ! h1g, 2020-03-10 + + + if (do_cldice .and. do_HM_splinter ) then + call secondary_ice_production(t(:,k), psacws(:,k), msacwi(:,k), nsacwi(:,k), mgncol) + else + nsacwi(:,k) = 0.0_r8 + msacwi(:,k) = 0.0_r8 + end if + + call accrete_rain_snow(t(:,k), rho(:,k), umr(:,k), ums(:,k), unr(:,k), uns(:,k), & + qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & + pracs(:,k), npracs(:,k), mgncol) + + call heterogeneous_rain_freezing(t(:,k), qric(:,k), nric(:,k), lamr(:,k), & + mnuccr(:,k), nnuccr(:,k), mgncol) + + if (do_sb_physics) then + call sb2001v2_accre_cld_water_rain(qcic(:,k), ncic(:,k), qric(:,k), & + rho(:,k), relvar(:,k), pra(:,k), npra(:,k), mgncol) + else + call accrete_cloud_water_rain(microp_uniform, qric(:,k), qcic(:,k), & + ncic(:,k), relvar(:,k), pra(:,k), npra(:,k), mgncol) + endif + + if (.not. microp_uniform) then + pra(:,k) = pra(:,k) * accre_enhan(:,k) + npra(:,k) = npra(:,k) * accre_enhan(:,k) + endif + + + call self_collection_rain(rho(:,k), qric(:,k), nric(:,k), nragg(:,k), mgncol) + + if (do_cldice) then + call accrete_cloud_ice_snow(t(:,k), rho(:,k), asn(:,k), qiic(:,k), niic(:,k), & + qsic(:,k), lams(:,k), n0s(:,k), prai(:,k), nprai(:,k), mgncol) + else + prai(:,k) = 0._r8 + nprai(:,k) = 0._r8 + end if + + call evaporate_sublimate_precip(t(:,k), rho(:,k), & + dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & + lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), & + qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & + pre(:,k), prds(:,k), am_evp_st(:,k), mgncol) + pre(:,k) = evap_subl_fac * pre(:,k) + prds(:,k) = evap_subl_fac * prds(:,k) + + call bergeron_process_snow(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), & + qvl(:,k), qvi(:,k), asn(:,k), qcic(:,k), qsic(:,k), lams(:,k), n0s(:,k), & + bergs(:,k), mgncol) + + bergs(:,k)=bergs(:,k)*micro_mg_bergs_eff_factor + + !+++PMC 12/3/12 - NEW VAPOR DEP/SUBLIMATION GOES HERE!!! + if (do_cldice) then + + call ice_deposition_sublimation(t(:,k), q(:,k), qc(:,k), qi(:,k), ni(:,k), & + icldm(:,k), rho(:,k), dv(:,k), qvl(:,k), qvi(:,k), & + berg(:,k), vap_dep(:,k), ice_sublim(:,k), mgncol) + vap_dep(:,k) = vap_dep(:,k) * ice_sublim_factor !h1g, 2017-07-17 + ice_sublim(:,k) = ice_sublim(:,k) * ice_sublim_factor !h1g, 2017-07-16 + berg(:,k)=berg(:,k)*micro_mg_berg_eff_factor + ! vap_dep(:,k) = vap_dep(:,k) + dqidt(:,k) ! h1g, 2016-12-19 + + where ( ice_sublim(:,k) < 0._r8 .and. qi(:,k) > qsmall .and. icldm(:,k) > mincld) + nsubi(:,k) = sublim_factor*ice_sublim(:,k) / qi(:,k) * ni(:,k) / icldm(:,k) + elsewhere + nsubi(:,k) = 0._r8 + end where + + ! bergeron process should not reduce nc unless + ! all ql is removed (which is handled elsewhere) + !in fact, nothing in this entire file makes nsubc nonzero. + nsubc(:,k) = 0._r8 + + end if !do_cldice + !---PMC 12/3/12 + + do i=1,mgncol + + ! 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 + + ! conservation of qc + !------------------------------------------------------------------- + + dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ & + psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*deltat + + if (dum.gt.qc(i,k)+dqcdt(i,k)*deltat+D_eros_l(i,k)*deltat) then + + ratio = (qc(i,k)/deltat+ max(dqcdt(i,k),0.0))/((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+ & + msacwi(i,k)+psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k)-D_eros_l(i,k)+max(-dqcdt(i,k),0.0))*omsm + prc(i,k) = prc(i,k)*ratio + pra(i,k) = pra(i,k)*ratio + mnuccc(i,k) = mnuccc(i,k)*ratio + mnucct(i,k) = mnucct(i,k)*ratio + msacwi(i,k) = msacwi(i,k)*ratio + psacws(i,k) = psacws(i,k)*ratio + bergs(i,k) = bergs(i,k)*ratio + berg(i,k) = berg(i,k)*ratio + D_eros_l(i,k) = D_eros_l(i,k)*ratio + if( dqcdt(i,k) < 0.0 ) dqcdt(i,k)=dqcdt(i,k)*ratio + qcrat(i,k) = ratio + if( ratio > 1) print*,'error ratio>1 in conservation of qc', i,k,ratio + if( ratio < 0) print*,'error ratio<0 in conservation of qc', i,k,ratio + else + qcrat(i,k) = 1._r8 + end if + + + !PMC 12/3/12: ratio is also frac of step w/ liquid. + !thus we apply berg for "ratio" of timestep and vapor + !deposition for the remaining frac of the timestep. + if (qc(i,k) >= qsmall) then + vap_dep(i,k) = vap_dep(i,k)*(1._r8-qcrat(i,k)) + end if + + end do + + do i=1,mgncol + + !================================================================= + ! apply limiter to ensure that ice/snow sublimation and rain evap + ! don't push conditions into supersaturation, and ice deposition/nucleation don't + ! push conditions into sub-saturation + ! note this is done after qc conservation since we don't know how large + ! vap_dep is before then + ! estimates are only approximate since other process terms haven't been limited + ! for conservation yet + + ! first limit ice deposition/nucleation vap_dep + mnuccd + dum1 = vap_dep(i,k) + mnuccd(i,k) + if (dum1 > 1.e-20_r8) then + dum = (q(i,k)-qvi(i,k))/(1._r8 + xxls_squared*qvi(i,k)/(cpp*rv*t(i,k)**2))/deltat + dum = max(dum,0._r8) + if (dum1 > dum) then + ! Allocate the limited "dum" tendency to mnuccd and vap_dep + ! processes. Don't divide by cloud fraction; these are grid- + ! mean rates. + dum1 = mnuccd(i,k) / (vap_dep(i,k)+mnuccd(i,k)) + mnuccd(i,k) = dum*dum1 + vap_dep(i,k) = dum - mnuccd(i,k) + end if + end if + + end do + + do i=1,mgncol + + !=================================================================== + ! conservation of nc + !------------------------------------------------------------------- + dum = ((nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ & + npsacws(i,k)-nsubc(i,k))*lcldm(i,k) - npccn2(i,k) )*deltat + + if (dum.gt.nc(i,k)+nerosc(i,k)*lcldm(i,k)*deltat) then + ratio = ( nc(i,k)/deltat + npccn2(i,k) )/( (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+& + npsacws(i,k)-nsubc(i,k)-nerosc(i,k) )*lcldm(i,k) )*omsm + + nprc1(i,k) = nprc1(i,k) * ratio + npra(i,k) = npra(i,k) * ratio + nnuccc(i,k) = nnuccc(i,k) * ratio + nnucct(i,k) = nnucct(i,k) * ratio + npsacws(i,k) = npsacws(i,k)* ratio + nsubc(i,k) = nsubc(i,k) * ratio + nerosc(i,k) = nerosc(i,k) * ratio + end if + + mnuccri(i,k)=0._r8 + nnuccri(i,k)=0._r8 + + if (do_cldice) then + + ! freezing of rain to produce ice if mean rain size is smaller than Dcs + if (lamr(i,k) > qsmall .and. 1._r8/lamr(i,k) < Dcs) then + mnuccri(i,k)=mnuccr(i,k) + nnuccri(i,k)=nnuccr(i,k) + mnuccr(i,k)=0._r8 + nnuccr(i,k)=0._r8 + end if + end if + + end do + + do i=1,mgncol + ! conservation of rain mixing ratio + !------------------------------------------------------------------- + dum = ((-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*precip_frac(i,k)- & + (pra(i,k)+prc(i,k))*lcldm(i,k))*deltat + + ! note that qrtend is included below because of instantaneous freezing/melt + if (dum.gt.qr(i,k).and. & + (-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k)).ge.qsmall) then + ratio = (qr(i,k)/deltat+(pra(i,k)+prc(i,k))*lcldm(i,k))/ & + precip_frac(i,k)/(-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*omsm + pre(i,k)=pre(i,k)*ratio + pracs(i,k)=pracs(i,k)*ratio + mnuccr(i,k)=mnuccr(i,k)*ratio + mnuccri(i,k)=mnuccri(i,k)*ratio + end if + end do + + do i=1,mgncol + ! conservation of rain number + !------------------------------------------------------------------- + ! Add evaporation of rain number. + if (allow_rain_num_evap) then + if (pre(i,k) < 0._r8 .and. qr(i,k) > qsmall) then + nsubr(i,k) = max(-nr(i,k)/deltat, pre(i,k)*nr(i,k)/qr(i,k)) + else + nsubr(i,k) = 0._r8 + endif + else + ! neglect evaporation of nr, allow_rain_num_evap = .false. h1g, 2017-02-27 + nsubr(i,k) = 0._r8 + end if + end do + + do i=1,mgncol + dum = ((-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*precip_frac(i,k)- & + nprc(i,k)*lcldm(i,k))*deltat + + if (dum.gt.nr(i,k)) then + ratio = (nr(i,k)/deltat+nprc(i,k)*lcldm(i,k))/precip_frac(i,k)/ & + (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*omsm + + nragg(i,k)=nragg(i,k)*ratio + npracs(i,k)=npracs(i,k)*ratio + nnuccr(i,k)=nnuccr(i,k)*ratio + nsubr(i,k)=nsubr(i,k)*ratio + nnuccri(i,k)=nnuccri(i,k)*ratio + end if + end do + + if (do_cldice) then + + do i=1,mgncol + + ! conservation of qi + !------------------------------------------------------------------- + + dum = ((-mnuccc(i,k)-mnucct(i,k)-mnudep(i,k)-msacwi(i,k))*lcldm(i,k)+(prci(i,k)+ & + prai(i,k))*icldm(i,k)-mnuccri(i,k)*precip_frac(i,k) & + -ice_sublim(i,k)-vap_dep(i,k)-berg(i,k)-mnuccd(i,k))*deltat + + if (dum.gt.qi(i,k)+dqidt(i,k)*deltat+D_eros_i(i,k)*deltat) then + ratio = (qi(i,k)/deltat+max(dqidt(i,k),0.0)+vap_dep(i,k)+berg(i,k)+mnuccd(i,k)+ & + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+ & + mnuccri(i,k)*precip_frac(i,k))/ & + ((prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k)-D_eros_i(i,k)+max(-dqidt(i,k),0.0))*omsm + + if( dqidt(i,k) < 0.0 ) dqidt(i,k)=dqidt(i,k)*ratio + if( ratio > 1) print*,"error ratio>1 in conservation of qi",i,k,ratio + if( ratio < 0) then + print*,"error ratio<0 in conservation of qi",i,k, lon(i), lat(i), it + print*,"dum=", dum, qi(i,k), dqidt(i,k), D_eros_i(i,k), deltat + print*,"conv of qi", -mnuccc(i,k), -mnucct(i,k), -mnudep(i,k), -msacwi(i,k), lcldm(i,k) + print*, "==", prci(i,k), prai(i,k), icldm(i,k), -mnuccri(i,k), precip_frac(i,k) + print*, "+++", -ice_sublim(i,k), -vap_dep(i,k), -berg(i,k), -mnuccd(i,k) + endif + + prci(i,k) = prci(i,k)*ratio + prai(i,k) = prai(i,k)*ratio + ice_sublim(i,k) = ice_sublim(i,k)*ratio + D_eros_i(i,k) = D_eros_i(i,k)*ratio + end if + end do + + end if + + if (do_cldice) then + + do i=1,mgncol + + ! conservation of ni + !------------------------------------------------------------------- + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = 0._r8 + end if + dum = ((-nnucct(i,k)-tmpfrz-nnudep(i,k)-nsacwi(i,k))*lcldm(i,k)+(nprci(i,k)+ & + nprai(i,k)-nsubi(i,k))*icldm(i,k)-nnuccri(i,k)*precip_frac(i,k) - nnuccd(i,k) )*deltat + + if (dum.gt.ni(i,k)+nerosi(i,k)*icldm(i,k)*deltat) then + ratio = (ni(i,k)/deltat+ nnuccd(i,k)+& + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+ & + nnuccri(i,k)*precip_frac(i,k))/ & + ((nprci(i,k)+nprai(i,k)-nsubi(i,k)-nerosi(i,k))*icldm(i,k))*omsm + nprci(i,k) = nprci(i,k)*ratio + nprai(i,k) = nprai(i,k)*ratio + nsubi(i,k) = nsubi(i,k)*ratio + nerosi(i,k)= nerosi(i,k)*ratio + end if + end do + end if + + do i=1,mgncol + + ! conservation of snow mixing ratio + !------------------------------------------------------------------- + dum = (-(prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k)-(prai(i,k)+prci(i,k))*icldm(i,k) & + -(bergs(i,k)+psacws(i,k))*lcldm(i,k))*deltat + + if (dum.gt.qs(i,k).and.-prds(i,k).ge.qsmall) then + ratio = (qs(i,k)/deltat+(prai(i,k)+prci(i,k))*icldm(i,k)+ & + (bergs(i,k)+psacws(i,k))*lcldm(i,k)+(pracs(i,k)+mnuccr(i,k))*precip_frac(i,k))/ & + precip_frac(i,k)/(-prds(i,k))*omsm + prds(i,k)=prds(i,k)*ratio + end if + + end do + + do i=1,mgncol + + ! conservation of snow number + !------------------------------------------------------------------- + ! calculate loss of number due to sublimation + ! for now neglect sublimation of ns + +!--> h1g, 2019-12-03 + if (allow_snow_num_sublimation) then + if (prds(i,k) < 0._r8 .and. qs(i,k) > qsmall ) then + dum = prds(i,k)*deltat/qs(i,k) + dum = max(-1._r8,dum) + nsubs(i,k) = dum*ns(i,k)/deltat + else + nsubs(i,k)=0._r8 + endif + else + ! neglect sublimation of ns, allow_snow_num_sublimation = .false. h1g, 2019-12-03 + nsubs(i,k)=0._r8 + endif +!<-- h1g, 2019-12-03 + + + dum = ((-nsagg(i,k)-nsubs(i,k)-nnuccr(i,k))*precip_frac(i,k)-nprci(i,k)*icldm(i,k))*deltat + + if (dum.gt.ns(i,k)) then + ratio = (ns(i,k)/deltat+nnuccr(i,k)* & + precip_frac(i,k)+nprci(i,k)*icldm(i,k))/precip_frac(i,k)/ & + (-nsubs(i,k)-nsagg(i,k))*omsm + nsubs(i,k)=nsubs(i,k)*ratio + nsagg(i,k)=nsagg(i,k)*ratio + end if + + end do + + do i=1,mgncol + + ! next limit ice and snow sublimation and rain evaporation + ! get estimate of q and t at end of time step + ! don't include other microphysical processes since they haven't + ! been limited via conservation checks yet + + if ((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k) < -1.e-20_r8) then + + qtmp=q(i,k)-(ice_sublim(i,k)+vap_dep(i,k)+mnuccd(i,k)+ & + (pre(i,k)+prds(i,k))*precip_frac(i,k))*deltat + ttmp=t(i,k)+((pre(i,k)*precip_frac(i,k))*xxlv+ & + (prds(i,k)*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k))*xxls)*deltat/cpp + + if ( ttmp .lt.-150.0+273.15 .or. ttmp .gt.90+273.15) & + write(*,'(a, i4, 2f9.4, 15e12.3)') 'MG2: bad temperature@2117', k, lon(i), lat(i), & + ttmp, t(i,k), pre(i,k), precip_frac(i,k), prds(i,k),vap_dep(i,k), ice_sublim(i,k), mnuccd(i,k), & + qtmp, q(i,k), p(i,k) + + ! use rhw to allow ice supersaturation + call compute_qs(ttmp, p(i,k), qvn, q = q(i,k), & + esat = esn, es_over_liq = .true.) + + ! modify ice/precip evaporation rate if q > qsat + if (qtmp > qvn) then + + dum1=pre(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k)) + dum2=prds(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k)) + ! recalculate q and t after vap_dep and mnuccd but without evap or sublim + qtmp=q(i,k)-(vap_dep(i,k)+mnuccd(i,k))*deltat + ttmp=t(i,k)+((vap_dep(i,k)+mnuccd(i,k))*xxls)*deltat/cpp + + ! use rhw to allow ice supersaturation + call compute_qs(ttmp, p(i,k), qvn, q = q(i,k), & + esat = esn, es_over_liq = .true.) + + dum=(qtmp-qvn)/(1._r8 + xxlv_squared*qvn/(cpp*rv*ttmp**2)) + dum=min(dum,0._r8) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + pre(i,k)=dum*dum1/deltat/precip_frac(i,k) + + ! do separately using RHI for prds and ice_sublim + call compute_qs(ttmp, p(i,k), qvn, q = q(i,k), & + esat = esn, es_over_liq_and_ice = .true. ) + + dum=(qtmp-qvn)/(1._r8 + xxls_squared*qvn/(cpp*rv*ttmp**2)) + dum=min(dum,0._r8) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + prds(i,k) = dum*dum2/deltat/precip_frac(i,k) + + ! don't divide ice_sublim by cloud fraction since it is grid-averaged + dum1 = (1._r8-dum1-dum2) + ice_sublim(i,k) = dum*dum1/deltat + end if + end if + + end do + + ! Big "administration" loop enforces conservation, updates variables + ! that accumulate over substeps, and sets output variables. + + do i=1,mgncol + + ! get tendencies due to microphysical conversion processes + !========================================================== + ! note: tendencies are multiplied by appropriate cloud/precip + ! fraction to get grid-scale values + ! note: vap_dep is already grid-average values + + ! The net tendencies need to be added to rather than overwritten, + ! because they may have a value already set for instantaneous + ! melting/freezing. + + qvlat(i,k) = qvlat(i,k)-dqcdt(i,k)-dqidt(i,k)-(pre(i,k)+prds(i,k))*precip_frac(i,k)-& + vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) - D_eros_l(i,k) - D_eros_i(i,k) + + ! if ( i==7 .and. k==31 ) print*,'2001 tlat= ', i,k, 'dqcdt',dqcdt(i,k), 'D_eros_l',D_eros_l(i,k), & + ! 'D_eros_i', D_eros_i(i,k), & + ! 'pre',pre(i,k), 'precip_frac', precip_frac(i,k), & + ! 'prds', prds(i,k), 'vap_dep', vap_dep(i,k), & + ! 'ice_sublim', ice_sublim(i,k), 'mnuccd', mnuccd(i,k),& + ! 'mnudep', mnudep(i,k), 'bergs',bergs(i,k), & + ! 'psacws',psacws(i,k), 'mnuccc', mnuccc(i,k), & + ! 'mnucct', mnucct(i,k), 'msacwi',msacwi(i,k), & + ! 'mnuccr',mnuccr(i,k), 'pracs',pracs(i,k), & + ! 'mnuccri',mnuccri(i,k), 'berg', berg(i,k) + + tlat(i,k) = tlat(i,k)+dqcdt(i,k)*xxlv+D_eros_l(i,k)*xxlv+dqidt(i,k)*xxls+D_eros_i(i,k)*xxls+ & + ((pre(i,k)*precip_frac(i,k))*xxlv & + +(prds(i,k)*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & + ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k))*lcldm(i,k)+(mnuccr(i,k)+ & + pracs(i,k)+mnuccri(i,k))*precip_frac(i,k)+berg(i,k))*xlf) + + qctend(i,k) = qctend(i,k)+dqcdt(i,k)+D_eros_l(i,k)+ & + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & + psacws(i,k)-bergs(i,k))*lcldm(i,k)-berg(i,k) + + if (do_cldice) then +! Note by h1g 2017-02-24, mnudep = 0.0 be default ( use_hetfrz_classnuc = .false. ) + qitend(i,k) = qitend(i,k)+dqidt(i,k)+D_eros_i(i,k)+ & + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+(-prci(i,k)- & + prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+ & + mnuccd(i,k)+mnuccri(i,k)*precip_frac(i,k) + end if + + qrtend(i,k) = qrtend(i,k)+ & + (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & + mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) + + qstend(i,k) = qstend(i,k)+ & + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(prds(i,k)+ & + pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) + + cmeout(i,k) = cmeout(i,k) + vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + + ! add output for cmei (accumulate) + cmeitot(i,k) = cmeitot(i,k) + vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + dqidt(i,k) + + ! assign variables for trop_mozart, these are grid-average + !------------------------------------------------------------------- + ! evaporation/sublimation is stored here as positive term + +!--> h1g, 2019-12-06 + evapsnow(i,k) = evapsnow(i,k) - prds(i,k)*precip_frac(i,k) + nevapr(i,k) = nevapr(i,k) - pre(i,k)*precip_frac(i,k) +!<-- h1g, 2019-12-06 + + ! change to make sure prain is positive: do not remove snow from + ! prain used for wet deposition + prain(i,k) = prain(i,k)+(pra(i,k)+prc(i,k))*lcldm(i,k)+(-pracs(i,k)- & + mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) + prodsnow(i,k) = prodsnow(i,k)+(prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(& + pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) + + ! following are used to calculate 1st order conversion rate of cloud water + ! to rain and snow (1/s), for later use in aerosol wet removal routine + ! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc + ! used to calculate pra, prc, ... in this routine + ! qcsinksum_rate1ord = { rate of direct transfer of cloud water to rain & snow } + ! (no cloud ice or bergeron terms) +!--> h1g, 2019-12-06 + qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) + (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) + ! Avoid zero/near-zero division. + ! qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) / & + ! max(qc(i,k),1.0e-30_r8) +!<-- h1g, 2019-12-06 + + preo(i,k) = preo(i,k) + pre(i,k)*precip_frac(i,k) + prdso(i,k) = prdso(i,k) + prds(i,k)*precip_frac(i,k) + + eroslo(i,k) = eroslo(i,k) + D_eros_l(i,k) + erosio(i,k) = erosio(i,k) + D_eros_i(i,k) + + cmelo(i,k) = cmelo(i,k) + dqcdt(i,k) + + ! microphysics output, note this is grid-averaged + pratot(i,k) = pratot(i,k)+pra(i,k)*lcldm(i,k) + prctot(i,k) = prctot(i,k)+prc(i,k)*lcldm(i,k) + mnuccctot(i,k) = mnuccctot(i,k)+mnuccc(i,k)*lcldm(i,k) + mnuccttot(i,k) = mnuccttot(i,k)+mnucct(i,k)*lcldm(i,k) + mnuccdtot(i,k) = mnuccdtot(i,k)+mnuccd(i,k) + + msacwitot(i,k) = msacwitot(i,k)+msacwi(i,k)*lcldm(i,k) + psacwstot(i,k) = psacwstot(i,k)+psacws(i,k)*lcldm(i,k) + bergstot(i,k) = bergstot(i,k)+bergs(i,k)*lcldm(i,k) + bergtot(i,k) = bergtot(i,k)+berg(i,k) + prcitot(i,k) = prcitot(i,k)+prci(i,k)*icldm(i,k) + praitot(i,k) = praitot(i,k)+prai(i,k)*icldm(i,k) + + pracstot(i,k) = pracstot(i,k)+pracs(i,k)*precip_frac(i,k) + mnuccrtot(i,k) = mnuccrtot(i,k)+mnuccr(i,k)*precip_frac(i,k) + mnuccritot(i,k) = mnuccritot(i,k)+mnuccri(i,k)*precip_frac(i,k) ! h1g, 2020-02-11 + + nctend(i,k) = nctend(i,k)+nerosc(i,k)*lcldm(i,k) + npccn2(i,k) + & + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & + -npra(i,k)-nprc1(i,k))*lcldm(i,k) + + if (do_cldice) then + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = 0._r8 + end if + nitend(i,k) = nitend(i,k)+nerosi(i,k)*icldm(i,k)+ nnuccd(i,k)+& + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- & + nprai(i,k))*icldm(i,k)+nnuccri(i,k)*precip_frac(i,k) + end if + + nstend(i,k) = nstend(i,k)+(nsubs(i,k)+ & + nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k)+nprci(i,k)*icldm(i,k) + + nrtend(i,k) = nrtend(i,k)+ & + nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & + -nnuccri(i,k)+nragg(i,k))*precip_frac(i,k) + + ! make sure that ni at advanced time step does not exceed + ! maximum (existing N + source terms*dt), which is possible if mtime < deltat + ! note that currently mtime = deltat + !================================================================ + +! ---> h1g, 2017-03-03 + IF (diag_id%qnidt_nucclim1 + diag_id%qni_nucclim1_col > 0) & + diag_4l(i,j,k,diag_pt%qnidt_nucclim1) = nitend(i,k) + + if (do_cldice .and. nitend(i,k).gt.0._r8.and.ni(i,k)+nitend(i,k)*deltat.gt.nimax(i,k)) then + ! nitend(i,k)=max(0._r8,(nimax(i,k)-ni(i,k))/deltat) + end if + + IF (diag_id%qnidt_nucclim1 + diag_id%qni_nucclim1_col > 0) & + diag_4l(i,j,k,diag_pt%qnidt_nucclim1) = nitend(i,k) - diag_4l(i,j,k,diag_pt%qnidt_nucclim1) +! <--- h1g, 2017-03-03 + + end do + + ! End of "administration" loop + + end do micro_vert_loop ! end k loop + + !----------------------------------------------------- + ! convert rain/snow q and N for output to history, note, + ! output is for gridbox average + + qrout = qrout + qr + nrout = nrout + nr * rho + qsout = qsout + qs + nsout = nsout + ns * rho + + ! calculate n0r and lamr from rain mass and number + ! divide by precip fraction to get in-precip (local) values of + ! rain mass and number, divide by rhow to get rain number in kg^-1 + + do k=1,nlev + + call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), lamr(:,k), mgncol, n0=n0r(:,k)) + + ! Calculate rercld + + ! calculate mean size of combined rain and cloud water + + call calc_rercld(lamr(:,k), n0r(:,k), lamc(:,k), pgam(:,k), qric(:,k), qcic(:,k), ncic(:,k), & + rercld(:,k), mgncol) + + enddo + + ! Assign variables back to start-of-timestep values + ! Some state variables are changed before the main microphysics loop + ! to make "instantaneous" adjustments. Afterward, we must move those changes + ! back into the tendencies. + ! These processes: + ! - Droplet activation (npccn, impacts nc) + ! - Instantaneous snow melting (minstsm/ninstsm, impacts qr/qs/nr/ns) + ! - Instantaneous rain freezing (minstfr/ninstrf, impacts qr/qs/nr/ns) + !================================================================================ + + ! Re-apply droplet activation tendency + ! nc = ncn + ! nctend = nctend + npccn2 + + ! ni = nin + ! nitend = nitend + nnuccd + + + ! Re-apply rain freezing and snow melting. + dum_2D = qs + qs = qstmp + qstend = qstend + (dum_2D-qs)/deltat + if (diag_id%snow_inst + diag_id%snow_inst_col > 0) & + diag_4l(:,j,:,diag_pt%snow_inst ) = diag_4l(:,j,:,diag_pt%snow_inst )+(dum_2D-qs)/deltat + + dum_2D = ns + ns = nstmp + nstend = nstend + (dum_2D-ns)/deltat + if (diag_id%snow_num_inst + diag_id%snow_num_inst_col > 0) & + diag_4l(:,j,:,diag_pt%snow_num_inst ) = diag_4l(:,j,:,diag_pt%snow_num_inst)+(dum_2D-ns)/deltat + + dum_2D = qr + qr = qrtmp + qrtend = qrtend + (dum_2D-qr)/deltat + if (diag_id%rain_inst + diag_id%rain_inst_col > 0) & + diag_4l(:,j,:,diag_pt%rain_inst ) = diag_4l(:,j,:,diag_pt%rain_inst )+(dum_2D-qr)/deltat + + + dum_2D = nr + nr = nrtmp + nrtend = nrtend + (dum_2D-nr)/deltat + if (diag_id%rain_num_inst + diag_id%rain_num_inst_col > 0) & + diag_4l(:,j,:,diag_pt%rain_num_inst ) = diag_4l(:,j,:,diag_pt%rain_num_inst )+(dum_2D-nr)/deltat + + !............................................................................. + !================================================================================ + ! modify to include snow. in prain & evap (diagnostic here: for wet dep) + nevapr = nevapr + evapsnow + prain = prain + prodsnow + + + + + + do k=1,nlev + do i=1,mgncol + + ! calculate sedimentation for cloud water and ice + !================================================================================ + + ! update in-cloud cloud mixing ratio and number concentration + ! with microphysical tendencies to calculate sedimentation, assign to dummy vars + ! note: these are in-cloud values***, hence we divide by cloud fraction + + dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat)/lcldm(i,k) + dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat)/icldm(i,k) + dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k),0._r8) + dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)/icldm(i,k),0._r8) + + dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat)/precip_frac(i,k) + dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat)/precip_frac(i,k),0._r8) + dums(i,k) = (qs(i,k)+qstend(i,k)*deltat)/precip_frac(i,k) + dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat)/precip_frac(i,k),0._r8) + + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k)=ncnst/rho(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k)=ninst/rho(i,k) + end if + enddo + enddo + + do k=1,nlev + + ! obtain new slope parameter to avoid possible singularity + + call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & + lami(:,k), mgncol) + + call size_dist_param_liq(mg_liq_props, dumc(:,k), dumnc(:,k), rho(:,k), & + pgam(:,k), lamc(:,k), mgncol) + + enddo + + do k=1,nlev + do i=1,mgncol + + ! calculate number and mass weighted fall velocity for droplets and cloud ice + !------------------------------------------------------------------- + + + if (dumc(i,k).ge.qsmall) then + + vtrmc(i,k)=acn(i,k)*gamma(4._r8+bc+pgam(i,k))/ & + (lamc(i,k)**bc*gamma(pgam(i,k)+4._r8)) + + fc(i,k) = g*rho(i,k)*vtrmc(i,k) + + fnc(i,k) = g*rho(i,k)* & + acn(i,k)*gamma(1._r8+bc+pgam(i,k))/ & + (lamc(i,k)**bc*gamma(pgam(i,k)+1._r8)) + else + fc(i,k) = 0._r8 + fnc(i,k)= 0._r8 + end if + + ! calculate number and mass weighted fall velocity for cloud ice + + if (dumi(i,k).ge.qsmall) then + + vtrmi(i,k)=min(ain(i,k)*gamma_bi_plus4/(6._r8*lami(i,k)**bi), & + 1.2_r8*rhof(i,k)) + + fi(i,k) = g*rho(i,k)*vtrmi(i,k) + fni(i,k) = g*rho(i,k)* & + min(ain(i,k)*gamma_bi_plus1/lami(i,k)**bi,1.2_r8*rhof(i,k)) + + ! adjust the ice fall velocity for smaller (r < 20 um) ice + ! particles (blend over 18-20 um) + irad = 1.5_r8 / lami(i,k) * 1e6_r8 + ifrac = min(1._r8, max(0._r8, (irad - 18._r8) / 2._r8)) + + if (ifrac .lt. 1._r8) then + vtrmi(i,k) = ifrac * vtrmi(i,k) + & + (1._r8 - ifrac) * & + min(ajn(i,k)*gamma_bj_plus4/(6._r8*lami(i,k)**bj), & + 1.2_r8*rhof(i,k)) + + fi(i,k) = g*rho(i,k)*vtrmi(i,k) + fni(i,k) = ifrac * fni(i,k) + & + (1._r8 - ifrac) * & + g*rho(i,k)* & + min(ajn(i,k)*gamma_bj_plus1/lami(i,k)**bj,1.2_r8*rhof(i,k)) + end if + else + fi(i,k) = 0._r8 + fni(i,k)= 0._r8 + end if + + enddo + + enddo + + + do k=1,nlev + + ! fallspeed for rain + + call size_dist_param_basic(mg_rain_props, dumr(:,k), dumnr(:,k), & + lamr(:,k), mgncol) + enddo + + do k=1,nlev + + do i=1,mgncol + if (lamr(i,k).ge.qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) + + unr(i,k) = min(arn(i,k)*gamma_br_plus1/lamr(i,k)**br,9.1_r8*rhof(i,k)) + umr(i,k) = min(arn(i,k)*gamma_br_plus4/(6._r8*lamr(i,k)**br),9.1_r8*rhof(i,k)) + + fr(i,k) = g*rho(i,k)*umr(i,k) + fnr(i,k) = g*rho(i,k)*unr(i,k) + + else + fr(i,k)=0._r8 + fnr(i,k)=0._r8 + end if + + ! fallspeed for snow + + call size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), & + lams(i,k)) + + if (lams(i,k).ge.qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) + ums(i,k) = min(asn(i,k)*gamma_bs_plus4/(6._r8*lams(i,k)**bs),1.2_r8*rhof(i,k)) + uns(i,k) = min(asn(i,k)*gamma_bs_plus1/lams(i,k)**bs,1.2_r8*rhof(i,k)) + + fs(i,k) = g*rho(i,k)*ums(i,k) + fns(i,k) = g*rho(i,k)*uns(i,k) + + else + fs(i,k)=0._r8 + fns(i,k)=0._r8 + end if + + ! redefine dummy variables - sedimentation is calculated over grid-scale + ! quantities to ensure conservation + + dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat) + dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat),0._r8) + dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat) + dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat),0._r8) + dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat) + dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat),0._r8) + dums(i,k) = (qs(i,k)+qstend(i,k)*deltat) + dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat),0._r8) + + if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8 + if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8 + if (dumr(i,k).lt.qsmall) dumnr(i,k)=0._r8 + if (dums(i,k).lt.qsmall) dumns(i,k)=0._r8 + + enddo + end do !!! vertical loop + +if ( do_implicit_fall ) then + fc = vfac_drop * fc/g/rho + fnc = vfac_drop * fnc/g/rho + fi = vfac_ice * fi/g/rho + fni = vfac_ice * fni/g/rho + + fr = vfactor * fr/g/rho + fnr = vfactor * fnr/g/rho + fs = vfactor * fs/g/rho + fns = vfactor * fns/g/rho + + ! cloud water (mass) sedimentation + do i=1,mgncol + dum_1D(:) = dumc(i,:) + call implicit_fall ( deltat, 1, nlev, zhalf(i,:) , fc(i,:), pdel(i,:), dum_1D, precip, flx) + do k=1,nlev + lflx(i,k+1) = lflx(i,k+1) + flx(k)/g/deltat + qcsedten(i,k)= qcsedten(i,k) + (dum_1D(k) - dumc(i,k))/deltat + qctend(i,k) = qctend(i,k) + (dum_1D(k) - dumc(i,k))/deltat + enddo + if ( precip .ge. 0.0 ) then !h1g, 2019-11-26, ensure numerical stability + prect(i) = prect(i)+precip/g/deltat/1000._r8 + endif + enddo + + ! cloud water (number) sedimentation + do i=1,mgncol + dum_1D(:) = dumnc(i,:) + call implicit_fall ( deltat, 1, nlev, zhalf(i,:) , fnc(i,:), pdel(i,:), dum_1D, precip, flx) + do k=1,nlev + nctend(i,k) = nctend(i,k) + (dum_1D(k) - dumnc(i,k))/deltat + IF ( diag_id%qndt_sedi + diag_id%qn_sedi_col > 0 ) & + diag_4l(i,j,k,diag_pt%qndt_sedi) = & + diag_4l(i,j,k,diag_pt%qndt_sedi) + (dum_1D(k) - dumnc(i,k))/deltat + enddo + enddo + + ! cloud ice (mass) sedimentation + do i=1,mgncol + dum_1D(:) = dumi(i,:) + call implicit_fall ( deltat, 1, nlev, zhalf(i,:) , fi(i,:), pdel(i,:), dum_1D, precip, flx) + do k=1,nlev + iflx(i,k+1) = iflx(i,k+1) + flx(k)/g/deltat + qisedten(i,k)= qisedten(i,k) + (dum_1D(k) - dumi(i,k))/deltat + qitend(i,k) = qitend(i,k) + (dum_1D(k) - dumi(i,k))/deltat + enddo + if ( precip .ge. 0.0 ) then !h1g, 2019-11-26, ensure numerical stability + prect(i) = prect(i) + precip/g/deltat/1000._r8 + preci(i) = preci(i) + precip/g/deltat/1000._r8 + endif + enddo + + ! cloud ice (number) sedimentation + do i=1,mgncol + dum_1D(:) = dumni(i,:) + call implicit_fall ( deltat, 1, nlev, zhalf(i,:) , fni(i,:), pdel(i,:), dum_1D, precip, flx) + do k=1,nlev + nitend(i,k) = nitend(i,k) + (dum_1D(k) - dumni(i,k))/deltat + IF ( diag_id%qnidt_sedi + diag_id%qni_sedi_col > 0 ) & + diag_4l(i,j,k,diag_pt%qnidt_sedi) = & + diag_4l(i,j,k,diag_pt%qnidt_sedi) + (dum_1D(k) - dumni(i,k))/deltat + enddo + enddo + + ! rain water (mass) sedimentation + do i=1,mgncol + dum_1D(:) = dumr(i,:) + call implicit_fall ( deltat, 1, nlev, zhalf(i,:) , fr(i,:), pdel(i,:), dum_1D, precip, flx) + do k=1,nlev + if ( flx(k) .ge. qsmall ) rflx(i,k+1) = rflx(i,k+1) + flx(k)/g/deltat !h1g, 2019-11-26, ensure numerical stability + qrsedten(i,k)= qrsedten(i,k) + (dum_1D(k) - dumr(i,k))/deltat + qrtend (i,k) = qrtend(i,k) + (dum_1D(k) - dumr(i,k))/deltat + enddo + if ( precip .ge. 0.0 ) then !h1g, 2019-11-26, ensure numerical stability + prect(i) = prect(i)+precip/g/deltat/1000._r8 + endif + enddo + + ! rain water (number) sedimentation + do i=1,mgncol + dum_1D(:) = dumnr(i,:) + call implicit_fall ( deltat, 1, nlev, zhalf(i,:) , fnr(i,:), pdel(i,:), dum_1D, precip, flx) + do k=1,nlev + nrtend(i,k) = nrtend(i,k) + (dum_1D(k) - dumnr(i,k))/deltat + IF ( diag_id%rain_num_sedi + diag_id%rain_num_sedi_col > 0 ) & + diag_4l(i,j,k,diag_pt%rain_num_sedi) = & + diag_4l(i,j,k,diag_pt%rain_num_sedi) + (dum_1D(k) - dumnr(i,k))/deltat + enddo + enddo + + + ! snow water (mass) sedimentation + do i=1,mgncol + dum_1D(:) = dums(i,:) + call implicit_fall ( deltat, 1, nlev, zhalf(i,:) , fs(i,:), pdel(i,:), dum_1D, precip, flx) + do k=1,nlev + if ( flx(k) .ge. qsmall ) sflx(i,k+1) = sflx(i,k+1) + flx(k)/g/deltat !h1g, 2019-11-26, ensure numerical stability + qssedten(i,k)= qssedten(i,k) + (dum_1D(k) - dums(i,k))/deltat + qstend(i,k) = qstend(i,k) + (dum_1D(k) - dums(i,k))/deltat + enddo + if ( precip .ge. 0.0 ) then !h1g, 2019-11-26, ensure numerical stability + prect(i) = prect(i)+precip/g/deltat/1000._r8 + preci(i) = preci(i)+precip/g/deltat/1000._r8 + endif + enddo + ! snow water (number) sedimentation + do i=1,mgncol + dum_1D(:) = dumns(i,:) + call implicit_fall ( deltat, 1, nlev, zhalf(i,:) , fns(i,:), pdel(i,:), dum_1D, precip, flx) + do k=1,nlev + nstend(i,k) = nstend(i,k) + (dum_1D(k) - dumns(i,k))/deltat + IF ( diag_id%snow_num_sedi + diag_id%snow_num_sedi_col > 0 ) & + diag_4l(i,j,k,diag_pt%snow_num_sedi) = & + diag_4l(i,j,k,diag_pt%snow_num_sedi) + (dum_1D(k) - dumns(i,k))/deltat + enddo + enddo + +else + + do k=1,nlev + do i=1,mgncol + pdel_inv(i,k) = 1._r8/pdel(i,k) + enddo + enddo + + ! initialize nstep for sedimentation sub-steps + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + + do i=1,mgncol + + nstep = 1 + int(max( & + maxval( fi(i,:)*pdel_inv(i,:)), & + maxval(fni(i,:)*pdel_inv(i,:))) & + * deltat) + +! if ( mpp_pe() == mpp_root_pe() ) & +! write(*, *) "nstep = ", nstep + + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + if (do_cldice) then + falouti = fi(i,:) * dumi(i,:) + faloutni = fni(i,:) * dumni(i,:) + else + falouti = 0._r8 + faloutni = 0._r8 + end if + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + faltndi = falouti(k)/pdel(i,k) + faltndni = faloutni(k)/pdel(i,k) + qitend(i,k) = qitend(i,k)-faltndi/nstep + nitend(i,k) = nitend(i,k)-faltndni/nstep + + ! sedimentation tendency for output + qisedten(i,k)=qisedten(i,k)-faltndi/nstep + IF ( diag_id%qnidt_sedi + diag_id%qni_sedi_col > 0 ) & + diag_4l(i,j,k,diag_pt%qnidt_sedi) = & + diag_4l(i,j,k,diag_pt%qnidt_sedi) - faltndni/nstep + + dumi(i,k) = dumi(i,k)-faltndi*deltat/nstep + dumni(i,k) = dumni(i,k)-faltndni*deltat/nstep + + do k = 2,nlev + + ! for cloud liquid and ice, if cloud fraction increases with height + ! then add flux from above to both vapor and cloud water of current level + ! this means that flux entering clear portion of cell from above evaporates + ! instantly + + ! note: this is not an issue with precip, since we assume max overlap + dum1=icldm(i,k)/icldm(i,k-1) + dum1=min(dum1,1._r8) + +!--> h1g, 2019-12-18 + if ( no_evap_in_sedimentation ) dum1 = 1.0 +!<-- h1g, 2019-12-18 + + faltndqie=(falouti(k)-falouti(k-1))/pdel(i,k) + + faltndi=(falouti(k)-dum1*falouti(k-1))/pdel(i,k) + faltndni=(faloutni(k)-dum1*faloutni(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + + qitend(i,k) = qitend(i,k)-faltndi/nstep + nitend(i,k) = nitend(i,k)-faltndni/nstep + + ! sedimentation tendency for output + qisedten(i,k)=qisedten(i,k)-faltndi/nstep + IF ( diag_id%qnidt_sedi + diag_id%qni_sedi_col > 0 ) & + diag_4l(i,j,k,diag_pt%qnidt_sedi) = & + diag_4l(i,j,k,diag_pt%qnidt_sedi) - faltndni/nstep + + ! add terms to to evap/sub of cloud water + + qvlat(i,k)=qvlat(i,k)-(faltndqie-faltndi)/nstep + ! for output + qisevap(i,k)=qisevap(i,k)-(faltndqie-faltndi)/nstep + tlat(i,k)=tlat(i,k)+(faltndqie-faltndi)*xxls/nstep + + dumi(i,k) = dumi(i,k)-faltndi*deltat/nstep + dumni(i,k) = dumni(i,k)-faltndni*deltat/nstep + + end do + + ! Ice flux + do k = 1,nlev + iflx(i,k+1) = iflx(i,k+1) + falouti(k) / g / real(nstep) + end do + + ! units below are m/s + ! sedimentation flux at surface is added to precip flux at surface + ! to get total precip (cloud + precip water) rate + + prect(i) = prect(i)+falouti(nlev)/g/real(nstep)/1000._r8 + preci(i) = preci(i)+falouti(nlev)/g/real(nstep)/1000._r8 + end do + + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( & + maxval( fc(i,:)*pdel_inv(i,:)), & + maxval(fnc(i,:)*pdel_inv(i,:))) & + * deltat) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + faloutc = fc(i,:) * dumc(i,:) + faloutnc = fnc(i,:) * dumnc(i,:) + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + faltndc = faloutc(k)/pdel(i,k) + faltndnc = faloutnc(k)/pdel(i,k) + qctend(i,k) = qctend(i,k)-faltndc/nstep + nctend(i,k) = nctend(i,k)-faltndnc/nstep + + ! sedimentation tendency for output + qcsedten(i,k)=qcsedten(i,k)-faltndc/nstep + + IF ( diag_id%qndt_sedi + diag_id%qn_sedi_col > 0 ) & + diag_4l(i,j,k,diag_pt%qndt_sedi) = & + diag_4l(i,j,k,diag_pt%qndt_sedi) - faltndnc/nstep + + + dumc(i,k) = dumc(i,k)-faltndc*deltat/nstep + dumnc(i,k) = dumnc(i,k)-faltndnc*deltat/nstep + + do k = 2,nlev + + dum=lcldm(i,k)/lcldm(i,k-1) + dum=min(dum,1._r8) + +!--> h1g, 2019-12-18 + if ( no_evap_in_sedimentation ) dum = 1.0 +!<-- h1g, 2019-12-18 + + faltndqce=(faloutc(k)-faloutc(k-1))/pdel(i,k) + faltndc=(faloutc(k)-dum*faloutc(k-1))/pdel(i,k) + faltndnc=(faloutnc(k)-dum*faloutnc(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + qctend(i,k) = qctend(i,k)-faltndc/nstep + nctend(i,k) = nctend(i,k)-faltndnc/nstep + + ! sedimentation tendency for output + qcsedten(i,k)=qcsedten(i,k)-faltndc/nstep + IF ( diag_id%qndt_sedi + diag_id%qn_sedi_col > 0 ) & + diag_4l(i,j,k,diag_pt%qndt_sedi) = & + diag_4l(i,j,k,diag_pt%qndt_sedi) - faltndnc/nstep + + + ! add terms to to evap/sub of cloud water + qvlat(i,k)=qvlat(i,k)-(faltndqce-faltndc)/nstep + ! for output + qcsevap(i,k)=qcsevap(i,k)-(faltndqce-faltndc)/nstep + tlat(i,k)=tlat(i,k)+(faltndqce-faltndc)*xxlv/nstep + + dumc(i,k) = dumc(i,k)-faltndc*deltat/nstep + dumnc(i,k) = dumnc(i,k)-faltndnc*deltat/nstep + + end do + + !Liquid condensate flux here + do k = 1,nlev + lflx(i,k+1) = lflx(i,k+1) + faloutc(k) / g / real(nstep) + end do + + prect(i) = prect(i)+faloutc(nlev)/g/real(nstep)/1000._r8 + end do + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( & + maxval( fr(i,:)*pdel_inv(i,:)), & + maxval(fnr(i,:)*pdel_inv(i,:))) & + * deltat) + + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + faloutr = fr(i,:) * dumr(i,:) + faloutnr = fnr(i,:) * dumnr(i,:) + + ! top of model + k = 1 + ! add fallout terms to microphysical tendencies + faltndr = faloutr(k)/pdel(i,k) + faltndnr = faloutnr(k)/pdel(i,k) + qrtend(i,k) = qrtend(i,k)-faltndr/nstep + nrtend(i,k) = nrtend(i,k)-faltndnr/nstep + + ! sedimentation tendency for output + qrsedten(i,k)=qrsedten(i,k)-faltndr/nstep + IF ( diag_id%rain_num_sedi + diag_id%rain_num_sedi_col > 0 ) & + diag_4l(i,j,k,diag_pt%rain_num_sedi) = & + diag_4l(i,j,k,diag_pt%rain_num_sedi) - faltndnr/nstep + + dumr(i,k) = dumr(i,k)-faltndr*deltat/real(nstep) + dumnr(i,k) = dumnr(i,k)-faltndnr*deltat/real(nstep) + + do k = 2,nlev + + faltndr=(faloutr(k)-faloutr(k-1))/pdel(i,k) + faltndnr=(faloutnr(k)-faloutnr(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + qrtend(i,k) = qrtend(i,k)-faltndr/nstep + nrtend(i,k) = nrtend(i,k)-faltndnr/nstep + + ! sedimentation tendency for output + qrsedten(i,k)=qrsedten(i,k)-faltndr/nstep + IF ( diag_id%rain_num_sedi + diag_id%rain_num_sedi_col > 0 ) & + diag_4l(i,j,k,diag_pt%rain_num_sedi) = & + diag_4l(i,j,k,diag_pt%rain_num_sedi) - faltndnr/nstep + + dumr(i,k) = dumr(i,k)-faltndr*deltat/real(nstep) + dumnr(i,k) = dumnr(i,k)-faltndnr*deltat/real(nstep) + end do + + ! Rain Flux + do k = 1,nlev + rflx(i,k+1) = rflx(i,k+1) + faloutr(k) / g / real(nstep) + end do + prect(i) = prect(i)+faloutr(nlev)/g/real(nstep)/1000._r8 + + end do + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( & + maxval( fs(i,:)*pdel_inv(i,:)), & + maxval(fns(i,:)*pdel_inv(i,:))) & + * deltat) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + falouts = fs(i,:) * dums(i,:) + faloutns = fns(i,:) * dumns(i,:) + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + faltnds = falouts(k)/pdel(i,k) + faltndns = faloutns(k)/pdel(i,k) + qstend(i,k) = qstend(i,k)-faltnds/nstep + nstend(i,k) = nstend(i,k)-faltndns/nstep + + ! sedimentation tendency for output + qssedten(i,k)=qssedten(i,k)-faltnds/nstep + IF ( diag_id%snow_num_sedi + diag_id%snow_num_sedi_col > 0 ) & + diag_4l(i,j,k,diag_pt%snow_num_sedi) = & + diag_4l(i,j,k,diag_pt%snow_num_sedi) - faltndns/nstep + + dums(i,k) = dums(i,k)-faltnds*deltat/real(nstep) + dumns(i,k) = dumns(i,k)-faltndns*deltat/real(nstep) + + do k = 2,nlev + + faltnds=(falouts(k)-falouts(k-1))/pdel(i,k) + faltndns=(faloutns(k)-faloutns(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + qstend(i,k) = qstend(i,k)-faltnds/nstep + nstend(i,k) = nstend(i,k)-faltndns/nstep + + ! sedimentation tendency for output + qssedten(i,k)=qssedten(i,k)-faltnds/nstep + + dums(i,k) = dums(i,k)-faltnds*deltat/real(nstep) + dumns(i,k) = dumns(i,k)-faltndns*deltat/real(nstep) + + end do !! k loop + + ! Snow Flux + do k = 1,nlev + sflx(i,k+1) = sflx(i,k+1) + falouts(k) / g / real(nstep) + end do + prect(i) = prect(i)+falouts(nlev)/g/real(nstep)/1000._r8 + preci(i) = preci(i)+falouts(nlev)/g/real(nstep)/1000._r8 + + end do !! nstep loop + + enddo !! i loop + +endif +! end sedimentation + + tlat1 = tlat1 + tlat + t = t + tlat*deltat/cpp + + qvlat1 = qvlat1 + qvlat + q = q + qvlat*deltat + + qctend1 = qctend1 + qctend + qc = qc + qctend*deltat + + qitend1 = qitend1 + qitend + qi = qi + qitend*deltat + + nctend1 = nctend1 + nctend + nc = nc + nctend*deltat + + nitend1 = nitend1 + nitend + ni = ni + nitend*deltat + + qrtend1 = qrtend1 + qrtend + qr = qr + qrtend*deltat + + qstend1 = qstend1 + qstend + qs = qs + qstend*deltat + + nrtend1 = nrtend1 + nrtend + nr = nr + nrtend*deltat + + nstend1 = nstend1 + nstend + ns = ns + nstend*deltat + +!--> h1g, 2019-12-12, remove tiny or negative hydrometeor mass or number +!--> in order to avoid numerical instability + do k=1, nlev + do i=1, mgncol + if ( qi(i,k).lt. qsmall ) then + if (diag_id%qidt_tiny + diag_id%qi_tiny_col > 0) & + diag_4l(i,j,k,diag_pt%qidt_tiny) = & + diag_4l(i,j,k,diag_pt%qidt_tiny) - qi(i,k)/deltat + qitend1(i,k) = qitend1(i,k) - qi(i,k)/deltat + qi(i,k) = 0.0 + + qvlat1(i,k) = qvlat1(i,k) + qi(i,k)/deltat + q(i,k) = q(i,k) + qi(i,k) + tlat1(i,k) = tlat1(i,k) - qi(i,k)/deltat*xxls + t(i,k) = t(i,k) - qi(i,k)*xxls/cpp + endif + enddo + enddo + + do k=1, nlev + do i=1, mgncol + if ( ni(i,k).lt. qsmall ) then + if (diag_id%qnidt_tiny + diag_id%qni_tiny_col > 0) & + diag_4l(i,j,k,diag_pt%qnidt_tiny) = & + diag_4l(i,j,k,diag_pt%qnidt_tiny) - ni(i,k)/deltat + + nitend1(i,k) = nitend1(i,k) - ni(i,k)/deltat + ni(i,k) = 0.0 + endif + enddo + enddo + + do k=1, nlev + do i=1, mgncol + if ( qs(i,k).lt. qsmall ) then + if (diag_id%qsdt_tiny + diag_id%qs_tiny_col > 0) & + diag_4l(i,j,k,diag_pt%qsdt_tiny) = & + diag_4l(i,j,k,diag_pt%qsdt_tiny) - qs(i,k)/deltat + + qstend1(i,k) = qstend1(i,k) - qs(i,k)/deltat + qs(i,k) = 0.0 + + qvlat1(i,k) = qvlat1(i,k) + qs(i,k)/deltat + q(i,k) = q(i,k) + qs(i,k) + tlat1(i,k) = tlat1(i,k) - qs(i,k)/deltat*xxls + t(i,k) = t(i,k) - qs(i,k)*xxls/cpp + endif + enddo + enddo + + do k=1, nlev + do i=1, mgncol + if ( ns(i,k).lt. qsmall ) then + if (diag_id%qnsdt_tiny + diag_id%qns_tiny_col > 0) & + diag_4l(i,j,k,diag_pt%qnsdt_tiny) = & + diag_4l(i,j,k,diag_pt%qnsdt_tiny) - ns(i,k)/deltat + + nstend1(i,k) = nstend1(i,k) - ns(i,k)/deltat + ns(i,k) = 0.0 + endif + enddo + enddo + + do k=1, nlev + do i=1, mgncol + if ( qc(i,k).lt. qsmall ) then + if (diag_id%qldt_tiny + diag_id%ql_tiny_col > 0) & + diag_4l(i,j,k,diag_pt%qldt_tiny) = & + diag_4l(i,j,k,diag_pt%qldt_tiny) - qc(i,k)/deltat + qctend1(i,k) = qctend1(i,k) - qc(i,k)/deltat + qc(i,k) = 0.0 + + qvlat1(i,k) = qvlat1(i,k) + qc(i,k)/deltat + q(i,k) = q(i,k) + qc(i,k) + tlat1(i,k) = tlat1(i,k) - qc(i,k)/deltat*xxlv + t(i,k) = t(i,k) - qc(i,k)*xxlv/cpp + endif + enddo + enddo + + do k=1, nlev + do i=1, mgncol + if ( nc(i,k).lt.qsmall ) then + if (diag_id%qndt_tiny + diag_id%qn_tiny_col > 0) & + diag_4l(i,j,k,diag_pt%qndt_tiny) = & + diag_4l(i,j,k,diag_pt%qndt_tiny) - nc(i,k)/deltat + + nctend1(i,k) = nctend1(i,k) - nc(i,k)/deltat + nc(i,k) = 0.0 + endif + enddo + enddo + + do k=1, nlev + do i=1, mgncol + if ( qr(i,k).lt. qsmall ) then + if (diag_id%qrdt_tiny + diag_id%qr_tiny_col > 0) & + diag_4l(i,j,k,diag_pt%qrdt_tiny) = & + diag_4l(i,j,k,diag_pt%qrdt_tiny) - qr(i,k)/deltat + qrtend1(i,k) = qrtend1(i,k) - qr(i,k)/deltat + qr(i,k) = 0.0 + + qvlat1(i,k) = qvlat1(i,k) + qr(i,k)/deltat + q(i,k) = q(i,k) + qr(i,k) + tlat1(i,k) = tlat1(i,k) - qr(i,k)/deltat*xxlv + t(i,k) = t(i,k) - qr(i,k)*xxlv/cpp + endif + enddo + enddo + + do k=1, nlev + do i=1, mgncol + if ( nr(i,k).lt. qsmall ) then + if (diag_id%qnrdt_tiny + diag_id%qnr_tiny_col > 0) & + diag_4l(i,j,k,diag_pt%qnrdt_tiny) = & + diag_4l(i,j,k,diag_pt%qnrdt_tiny) - nr(i,k)/deltat + + nrtend1(i,k) = nrtend1(i,k) - nr(i,k)/deltat + nr(i,k) = 0.0 + endif + enddo + enddo + +!<-- h1g, 2019-12-12 + + + npccno = npccno + npccn2 + nprao = nprao - npra*lcldm + nprc1o = nprc1o - nprc1*lcldm + nerosco = nerosco + nerosc*lcldm + + nnuccco = nnuccco - nnuccc*lcldm + nnuccto = nnuccto - nnucct*lcldm + npsacwso = npsacwso - npsacws*lcldm + nsubco = nsubco + nsubc*lcldm + nucclimo = nucclimo + nucclim + + nnuccdo = nnuccdo + nnuccd + nerosio = nerosio + nerosi*icldm + nsacwio = nsacwio + nsacwi*lcldm + nsubio = nsubio + nsubi*icldm + nprcio = nprcio - nprci*icldm + npraio = npraio - nprai*icldm + nnuccrio = nnuccrio+ nnuccri*precip_frac + nucclim1io = nucclim1io + nucclim1i + +end do substepping ! iter loop, sub-step + deltat = deltatin + +prect = prect/real(iter) +preci = preci/real(iter) + +lflx = lflx /real(iter) +iflx = iflx /real(iter) +rflx = rflx /real(iter) +sflx = sflx /real(iter) + +qcsedten = qcsedten/real(iter) +qisedten = qisedten/real(iter) +qrsedten = qrsedten/real(iter) +qssedten = qssedten/real(iter) + +diag_4l(:,j,:,diag_pt%qndt_sedi) = diag_4l(:,j,:,diag_pt%qndt_sedi) /real(iter) +diag_4l(:,j,:,diag_pt%qnidt_sedi) = diag_4l(:,j,:,diag_pt%qnidt_sedi) /real(iter) +diag_4l(:,j,:,diag_pt%rain_num_sedi) = diag_4l(:,j,:,diag_pt%rain_num_sedi)/real(iter) +diag_4l(:,j,:,diag_pt%snow_num_sedi) = diag_4l(:,j,:,diag_pt%snow_num_sedi)/real(iter) + + ! assign variables back to start-of-timestep values before updating after sub-steps + !================================================================================ + + t = tn + q = qn + qc = qcn + nc = ncn + qi = qin + ni = nin + qr = qrn + nr = nrn + qs = qsn + ns = nsn + + tlat = tlat1/real(iter) + qvlat = qvlat1/real(iter) + qctend = qctend1/real(iter) + qitend = qitend1/real(iter) + nctend = nctend1/real(iter) + nitend = nitend1/real(iter) + + qrtend = qrtend1/real(iter) + qstend = qstend1/real(iter) + nrtend = nrtend1/real(iter) + nstend = nstend1/real(iter) + + diag_4l(:,j,:,diag_pt%qidt_tiny) = diag_4l(:,j,:,diag_pt%qidt_tiny)/real(iter) + diag_4l(:,j,:,diag_pt%qnidt_tiny) = diag_4l(:,j,:,diag_pt%qnidt_tiny)/real(iter) + + diag_4l(:,j,:,diag_pt%qsdt_tiny) = diag_4l(:,j,:,diag_pt%qsdt_tiny)/real(iter) + diag_4l(:,j,:,diag_pt%qnsdt_tiny) = diag_4l(:,j,:,diag_pt%qnsdt_tiny)/real(iter) + + diag_4l(:,j,:,diag_pt%qldt_tiny) = diag_4l(:,j,:,diag_pt%qldt_tiny)/real(iter) + diag_4l(:,j,:,diag_pt%qndt_tiny) = diag_4l(:,j,:,diag_pt%qndt_tiny)/real(iter) + + diag_4l(:,j,:,diag_pt%qrdt_tiny) = diag_4l(:,j,:,diag_pt%qrdt_tiny)/real(iter) + diag_4l(:,j,:,diag_pt%qnrdt_tiny) = diag_4l(:,j,:,diag_pt%qnrdt_tiny)/real(iter) + + + + ! divide output precip q and N by number of sub-steps to get average over time step + !================================================================================ + + qrout = qrout/real(iter) + qsout = qsout/real(iter) + nrout = nrout/real(iter) + nsout = nsout/real(iter) + + ! divide trop_mozart variables by number of sub-steps to get average over time step + !================================================================================ + + nevapr = nevapr/real(iter) + evapsnow = evapsnow/real(iter) + prain = prain/real(iter) + prodsnow = prodsnow/real(iter) + + cmeout = cmeout/real(iter) + + cmeitot = cmeitot/real(iter) + meltsdttot = meltsdttot/real(iter) + frzrdttot = frzrdttot /real(iter) + + where ( qc .gt. 0.0) + qcsinksum_rate1ord = qcsinksum_rate1ord/qc/real(iter) + end where + + preo = preo/real(iter) + prdso = prdso/real(iter) + + cmelo =cmelo/real(iter) + + eroslo=eroslo/real(iter) + erosio=erosio/real(iter) + + pratot=pratot/real(iter) + prctot=prctot/real(iter) + mnuccctot=mnuccctot/real(iter) + mnuccttot=mnuccttot/real(iter) + mnuccdtot=mnuccdtot/real(iter) + + msacwitot=msacwitot/real(iter) + psacwstot=psacwstot/real(iter) + bergstot=bergstot/real(iter) + bergtot=bergtot/real(iter) + prcitot=prcitot/real(iter) + praitot=praitot/real(iter) + + mnuccrtot =mnuccrtot/real(iter) + mnuccritot=mnuccritot/real(iter) ! h1g, 2020-02-11 + pracstot =pracstot /real(iter) + + npccno = npccno/real(iter) ! h1g, 2020-03-09 + nprc1o = nprc1o/real(iter) ! h1g, 2020-03-09 + nprao = nprao/real(iter) ! h1g, 2020-03-09 + nerosco= nerosco/real(iter) ! h1g, 2020-03-09 + nnuccco= nnuccco/real(iter) ! h1g, 2020-03-09 + nnuccto= nnuccto/real(iter) ! h1g, 2020-03-09 + npsacwso= npsacwso/real(iter) ! h1g, 2020-03-09 + nsubco = nsubco/real(iter) ! h1g, 2020-03-09 + + nnuccdo = nnuccdo/real(iter) ! h1g, 2020-06-29 + nerosio = nerosio/real(iter) ! h1g, 2020-06-30 + nsacwio = nsacwio/real(iter) ! h1g, 2020-06-29 + nsubio = nsubio/real(iter) ! h1g, 2020-06-29 + nprcio = nprcio/real(iter) ! h1g, 2020-06-29 + npraio = npraio/real(iter) ! h1g, 2020-06-29 + nnuccrio = nnuccrio/real(iter) ! h1g, 2020-06-30 + nucclim1io = nucclim1io/real(iter) ! h1g, 2020-06-29 + + + + if (diag_id%snow_inst + diag_id%snow_inst_col > 0) & + diag_4l(:,j,:,diag_pt%snow_inst ) = diag_4l(:,j,:,diag_pt%snow_inst )/real(iter) + if (diag_id%snow_num_inst + diag_id%snow_num_inst_col > 0) & + diag_4l(:,j,:,diag_pt%snow_num_inst ) = diag_4l(:,j,:,diag_pt%snow_num_inst)/real(iter) + if (diag_id%rain_inst + diag_id%rain_inst_col > 0) & + diag_4l(:,j,:,diag_pt%rain_inst ) = diag_4l(:,j,:,diag_pt%rain_inst )/real(iter) + if (diag_id%rain_num_inst + diag_id%rain_num_inst_col > 0) & + diag_4l(:,j,:,diag_pt%rain_num_inst ) = diag_4l(:,j,:,diag_pt%rain_num_inst )/real(iter) + + + + + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! get new update for variables that includes sedimentation tendency + ! note : here dum variables are grid-average, NOT in-cloud + + do k=1,nlev + do i=1,mgncol + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8) + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8) + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8) + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8) + + dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat,0._r8) + dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8) + dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat,0._r8) + dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8) + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k)=ncnst/rho(i,k)*lcldm(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k)=ninst/rho(i,k)*icldm(i,k) + end if + + if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8 + if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8 + if (dumr(i,k).lt.qsmall) dumnr(i,k)=0._r8 + if (dums(i,k).lt.qsmall) dumns(i,k)=0._r8 + + enddo + enddo + + ! calculate instantaneous processes (melting, homogeneous freezing) + !==================================================================== + + ! melting of snow at +2 C + do k=1,nlev + + do i=1,mgncol + + if (t(i,k)+tlat(i,k)/cpp*deltat > snowmelt) then + if (dums(i,k) > 0._r8) then + + ! make sure melting snow doesn't reduce temperature below threshold + dum = -xlf/cpp*dums(i,k) + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt. snowmelt) then + dum = (t(i,k)+tlat(i,k)/cpp*deltat-snowmelt)*cpp/xlf + dum = dum/dums(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qstend(i,k)=qstend(i,k)-dum*dums(i,k)/deltat + nstend(i,k)=nstend(i,k)-dum*dumns(i,k)/deltat + qrtend(i,k)=qrtend(i,k)+dum*dums(i,k)/deltat + nrtend(i,k)=nrtend(i,k)+dum*dumns(i,k)/deltat + + if (diag_id%snow_melt + diag_id%snow_melt_col > 0) & + diag_4l(i,j,k, diag_pt%snow_melt) = diag_4l(i,j,k, diag_pt%snow_melt)-dum*dums(i,k)/deltat + if (diag_id%snow_num_melt + diag_id%snow_num_melt_col > 0) & + diag_4l(i,j,k, diag_pt%snow_num_melt) = diag_4l(i,j,k, diag_pt%snow_num_melt)-dum*dumns(i,k)/deltat + + dum1=-xlf*dum*dums(i,k)/deltat + tlat(i,k)=tlat(i,k)+dum1 + + meltsdttot(i,k)=meltsdttot(i,k) + dum1 + end if + end if + enddo + enddo + do k=1,nlev + do i=1,mgncol + + ! freezing of rain at -5 C + + if (t(i,k)+tlat(i,k)/cpp*deltat < rainfrze) then + + if (dumr(i,k) > 0._r8) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = xlf/cpp*dumr(i,k) + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.rainfrze) then + dum = -(t(i,k)+tlat(i,k)/cpp*deltat-rainfrze)*cpp/xlf + dum = dum/dumr(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qrtend(i,k)=qrtend(i,k)-dum*dumr(i,k)/deltat + nrtend(i,k)=nrtend(i,k)-dum*dumnr(i,k)/deltat + + ! get mean size of rain = 1/lamr, add frozen rain to either snow or cloud ice + ! depending on mean rain size + + call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), & + lamr(i,k)) + + if (lamr(i,k) < 1._r8/Dcs) then + qstend(i,k)=qstend(i,k)+dum*dumr(i,k)/deltat + nstend(i,k)=nstend(i,k)+dum*dumnr(i,k)/deltat + + if (diag_id%srfrain_accrs + diag_id%srfrain_accrs_col > 0) & + diag_4l(i,j,k,diag_pt%srfrain_accrs) = diag_4l(i,j,k,diag_pt%srfrain_accrs)-dum*dumr(i,k)/deltat + + if (diag_id%rain_num2snow + diag_id%rain_num2snow_col > 0) & + diag_4l(i,j,k,diag_pt%rain_num2snow ) = diag_4l(i,j,k,diag_pt%rain_num2snow )-dum*dumnr(i,k)/deltat + + else + qitend(i,k)=qitend(i,k)+dum*dumr(i,k)/deltat + nitend(i,k)=nitend(i,k)+dum*dumnr(i,k)/deltat + if (diag_id%qidt_rain2ice + diag_id%qi_rain2ice_col > 0) & + diag_4l(i,j,k, diag_pt%qidt_rain2ice) = diag_4l(i,j,k, diag_pt%qidt_rain2ice)+dum*dumr(i,k)/deltat + if (diag_id%qnidt_rain2ice + diag_id%qni_rain2ice_col > 0) & + diag_4l(i,j,k, diag_pt%qnidt_rain2ice) = diag_4l(i,j,k, diag_pt%qnidt_rain2ice)+dum*dumnr(i,k)/deltat + end if + + ! heating tendency + dum1 = xlf*dum*dumr(i,k)/deltat + frzrdttot(i,k)=frzrdttot(i,k) + dum1 + tlat(i,k)=tlat(i,k)+dum1 + end if + end if + + enddo + enddo + if (do_cldice) then + do k=1,nlev + do i=1,mgncol + if (t(i,k)+tlat(i,k)/cpp*deltat > tmelt) then + if (dumi(i,k) > 0._r8) then + + ! limit so that melting does not push temperature below freezing + !----------------------------------------------------------------- + dum = -dumi(i,k)*xlf/cpp + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt.tmelt) then + dum = (t(i,k)+tlat(i,k)/cpp*deltat-tmelt)*cpp/xlf + dum = dum/dumi(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qctend(i,k)=qctend(i,k)+dum*dumi(i,k)/deltat + + ! for output + melttot(i,k)= dum*dumi(i,k)/deltat + + ! assume melting ice produces droplet + ! mean volume radius of 8 micron + + IF (diag_id%qndt_melt + diag_id%qn_melt_col > 0) & + diag_4l(i,j,k,diag_pt%qndt_melt) = diag_4l(i,j,k,diag_pt%qndt_melt) & + + 3._r8*dum*dumi(i,k)/deltat/ & + (4._r8*pi*5.12e-16_r8*rhow) + IF (diag_id%qidt_melt2 + diag_id%qi_melt2_col > 0) & + diag_4l(i,j,k,diag_pt%qidt_melt2) = qitend(i,k) + IF (diag_id%qnidt_melt + diag_id%qni_melt_col > 0) & + diag_4l(i,j,k,diag_pt%qnidt_melt) = nitend(i,k) + + nctend(i,k)=nctend(i,k)+3._r8*dum*dumi(i,k)/deltat/ & + (4._r8*pi*5.12e-16_r8*rhow) + + qitend(i,k)=((1._r8-dum)*dumi(i,k)-qi(i,k))/deltat + nitend(i,k)=((1._r8-dum)*dumni(i,k)-ni(i,k))/deltat + tlat(i,k)=tlat(i,k)-xlf*dum*dumi(i,k)/deltat + + IF (diag_id%qidt_melt2 + diag_id%qi_melt2_col > 0) & + diag_4l(i,j,k,diag_pt%qidt_melt2) = & + qitend(i,k) - diag_4l(i,j,k,diag_pt%qidt_melt2) + IF (diag_id%qnidt_melt + diag_id%qni_melt_col > 0) & + diag_4l(i,j,k,diag_pt%qnidt_melt) = & + nitend(i,k) - diag_4l(i,j,k,diag_pt%qnidt_melt) + end if + end if + enddo + enddo + + ! homogeneously freeze droplets at -40 C + !----------------------------------------------------------------- + + do k=1,nlev + do i=1,mgncol + if (t(i,k)+tlat(i,k)/cpp*deltat < 233.15_r8) then + if (dumc(i,k) > 0._r8) then + + ! limit so that freezing does not push temperature above threshold + dum = dumc(i,k)*xlf/cpp + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.233.15_r8) then + dum = -(t(i,k)+tlat(i,k)/cpp*deltat-233.15_r8)*cpp/xlf + dum = dum/dumc(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qitend(i,k)=qitend(i,k)+dum*dumc(i,k)/deltat + ! for output + homotot(i,k)=dum*dumc(i,k)/deltat + + IF (diag_id%qldt_freez + diag_id%ql_freez_col > 0) & + diag_4l(i,j,k,diag_pt%qldt_freez) = qctend(i,k) + sum_freeze(i,k) = qctend(i,k) + IF ( diag_id%qndt_ihom + diag_id%qn_ihom_col > 0) & + diag_4l(i,j,k,diag_pt%qndt_ihom) = nctend(i,k) + + ! assume 25 micron mean volume radius of homogeneously frozen droplets + ! consistent with size of detrained ice in stratiform.F90 + nitend(i,k)=nitend(i,k)+dum*3._r8*dumc(i,k)/(4._r8*3.14_r8*1.563e-14_r8* & + 500._r8)/deltat + qctend(i,k)=((1._r8-dum)*dumc(i,k)-qc(i,k))/deltat + + if ( do_liq_num_ihom ) & ! h1g, 2020-06-22 + nctend(i,k)=((1._r8-dum)*dumnc(i,k)-nc(i,k))/deltat + + tlat(i,k)=tlat(i,k)+xlf*dum*dumc(i,k)/deltat + + if( isnan( tlat(i,k) ) ) & + write(*,'(a, 2i5, 5f8.2, i5 )') 'NaN@2907', i, k, tlat(i,k), xlf, dum, dumc(i,k), deltat + + + IF (diag_id%qldt_freez + diag_id%ql_freez_col > 0) & + diag_4l(i,j,k,diag_pt%qldt_freez) = & + qctend(i,k) - diag_4l(i,j,k,diag_pt%qldt_freez) + sum_freeze(i,k) = -(qctend(i,k) - sum_freeze(i,k)) + IF (diag_id%qndt_ihom + diag_id%qn_ihom_col > 0) & + diag_4l(i,j,k,diag_pt%qndt_ihom) = & + nctend(i,k) - diag_4l(i,j,k,diag_pt%qndt_ihom) + IF ( diag_id%qnidt_ihom + diag_id%qni_ihom_col > 0 ) & + diag_4l(i,j,k,diag_pt%qnidt_ihom) = & + dum*3._r8*dumc(i,k)/ & + (4._r8*3.14_r8*1.563e-14_r8*500._r8)/deltat + end if + end if + enddo + enddo + ! remove any excess over-saturation, which is possible due to non-linearity when adding + ! together all microphysical processes + !----------------------------------------------------------------- + ! follow code similar to old CAM scheme + + do k=1,nlev + do i=1,mgncol + + qtmp=q(i,k)+qvlat(i,k)*deltat + ttmp=t(i,k)+tlat(i,k)/cpp*deltat + + if ( ttmp .lt.-150.0+273.15 .or. ttmp .gt.90+273.15) & + write(*,'(a,6f8.2)') 'MG2: bad temperature@2930', & + ttmp, t(i,k), tlat(i,k)/cpp*deltat, tlat(i,k), cpp, deltat + + ! use rhw to allow ice supersaturation + call compute_qs(ttmp, p(i,k), qvn, q = q(i,k), & + esat = esn, es_over_liq = .true.) + + if (qtmp > qvn .and. qvn > 0 .and. allow_sed_supersat) then + ! expression below is approximate since there may be ice deposition + dum = (qtmp-qvn)/(1._r8+xxlv_squared*qvn/(cpp*rv*ttmp**2))/deltat + ! add to output cme + cmeout(i,k) = cmeout(i,k)+dum + ! now add to tendencies, partition between liquid and ice based on temperature + + if( remove_super_RK ) then ! h1g, 2020-03-30 + if (ttmp > 233.15_r8) then + dum1=0.0_r8 + if ( tiedtke_macrophysics ) ssat_disposal(i,k) = 1._r8 + else + dum1=1.0_r8 + if ( tiedtke_macrophysics ) ssat_disposal(i,k) = 2._r8 + endif + else ! h1g, 2020-03-30 + + if (ttmp > 268.15_r8) then + dum1=0.0_r8 + ! now add to tendencies, partition between liquid and ice based on temperature + if ( tiedtke_macrophysics ) ssat_disposal(i,k) = 1._r8 + !------------------------------------------------------- + else if (ttmp < 238.15_r8) then + dum1=1.0_r8 + if ( tiedtke_macrophysics ) ssat_disposal(i,k) = 2._r8 + else + dum1=(268.15_r8-ttmp)/30._r8 + if ( tiedtke_macrophysics ) ssat_disposal(i,k) = 2._r8 + end if + endif ! h1g, 2020-03-30 + + dum = (qtmp-qvn)/(1._r8+(xxls*dum1+xxlv*(1._r8-dum1))**2 & + *qvn/(cpp*rv*ttmp**2))/deltat + qctend(i,k)=qctend(i,k)+dum*(1._r8-dum1) + ! for output + qcrestot(i,k)=dum*(1._r8-dum1) + qitend(i,k)=qitend(i,k)+dum*dum1 + qirestot(i,k)=dum*dum1 + qvlat(i,k)=qvlat(i,k)-dum + ! for output + qvres(i,k)=-dum + tlat(i,k)=tlat(i,k)+dum*(1._r8-dum1)*xxlv+dum*dum1*xxls + end if + enddo + enddo + end if + + ! calculate effective radius for pass to radiation code + !========================================================= + ! if no cloud water, default value is 10 micron for droplets, + ! 25 micron for cloud ice + + ! update cloud variables after instantaneous processes to get effective radius + ! variables are in-cloud to calculate size dist parameters + do k=1,nlev + do i=1,mgncol + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8)/lcldm(i,k) + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8)/icldm(i,k) + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8)/lcldm(i,k) + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8)/icldm(i,k) + + dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat,0._r8)/precip_frac(i,k) + dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8)/precip_frac(i,k) + dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat,0._r8)/precip_frac(i,k) + dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8)/precip_frac(i,k) + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k)=ncnst/rho(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k)=ninst/rho(i,k) + end if + + ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1 + dumc(i,k)=min(dumc(i,k),5.e-3_r8) + dumi(i,k)=min(dumi(i,k),5.e-3_r8) + ! limit in-precip mixing ratios + dumr(i,k)=min(dumr(i,k),10.e-3_r8) + dums(i,k)=min(dums(i,k),10.e-3_r8) + enddo + enddo + ! cloud ice effective radius + !----------------------------------------------------------------- + + if (do_cldice) then + do k=1,nlev + do i=1,mgncol + if (dumi(i,k).ge.qsmall) then + + dum_2D(i,k) = dumni(i,k) + call size_dist_param_basic(mg_ice_props, dumi(i,k), dumni(i,k), & + lami(i,k), dumni0) + + if (dumni(i,k) /=dum_2D(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + if (diag_id%qnidt_size_adj + diag_id%qni_size_adj_col > 0) & + diag_4l(i,j,k,diag_pt%qnidt_size_adj) = nitend(i,k) + + if ( do_ice_num_adjust ) & ! h1g, 2020-07-01 + nitend(i,k)=(dumni(i,k)*icldm(i,k)-ni(i,k))/deltat + + if (diag_id%qnidt_size_adj + diag_id%qni_size_adj_col > 0) & + diag_4l(i,j,k,diag_pt%qnidt_size_adj) = nitend(i,k) & + - diag_4l(i,j,k,diag_pt%qnidt_size_adj) + end if + + effi(i,k) = 1.5_r8/lami(i,k)*1.e6_r8 + sadice(i,k) = 2._r8*pi*(lami(i,k)**(-3))*dumni0*rho(i,k)*1.e-2_r8 ! m2/m3 -> cm2/cm3 + + else + effi(i,k) = 25._r8 + sadice(i,k) = 0._r8 + end if + + ! ice effective diameter for david mitchell's optics + deffi(i,k)=effi(i,k)*rhoi/rhows*2._r8 + enddo + enddo + else + do k=1,nlev + do i=1,mgncol + ! NOTE: If CARMA is doing the ice microphysics, then the ice effective + ! radius has already been determined from the size distribution. + effi(i,k) = re_ice(i,k) * 1.e6_r8 ! m -> um + deffi(i,k)=effi(i,k) * 2._r8 + sadice(i,k) = 4._r8*pi*(effi(i,k)**2)*ni(i,k)*rho(i,k)*1e-2_r8 + enddo + enddo + end if + + ! cloud droplet effective radius + !----------------------------------------------------------------- + do k=1,nlev + do i=1,mgncol + if (dumc(i,k).ge.qsmall .and. do_liq_num_adjust) then + + ! switch for specification of droplet and crystal number + if (nccons) then + ! make sure nc is consistence with the constant N by adjusting tendency, need + ! to multiply by cloud fraction + ! note that nctend may be further adjusted below if mean droplet size is + ! out of bounds + nctend(i,k)=(ncnst/rho(i,k)*lcldm(i,k)-nc(i,k))/deltat + end if + IF (diag_id%qndt_size_adj + diag_id%qn_size_adj_col > 0) & + diag_4l(i,j,k,diag_pt%qndt_size_adj ) = nctend(i,k) + + dum = dumnc(i,k) + call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & + pgam(i,k), lamc(i,k)) + + if (dum /= dumnc(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + nctend(i,k)=(dumnc(i,k)*lcldm(i,k)-nc(i,k))/deltat + end if + IF (diag_id%qndt_size_adj + diag_id%qn_size_adj_col > 0) & + diag_4l(i,j,k,diag_pt%qndt_size_adj ) = & + nctend(i,k) - diag_4l(i,j,k,diag_pt%qndt_size_adj ) + + effc(i,k) = (pgam(i,k)+3._r8)/lamc(i,k)/2._r8*1.e6_r8 + !assign output fields for shape here + lamcrad(i,k)=lamc(i,k) + pgamrad(i,k)=pgam(i,k) + + + ! recalculate effective radius for constant number, in order to separate + ! first and second indirect effects + !====================================== + ! assume constant number of 10^8 kg-1 + + dumnc(i,k)=1.e8_r8 + + ! Pass in "false" adjust flag to prevent number from being changed within + ! size distribution subroutine. + call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & + pgam(i,k), lamc(i,k)) + + effc_fn(i,k) = (pgam(i,k)+3._r8)/lamc(i,k)/2._r8*1.e6_r8 + + else + effc(i,k) = 10._r8 + lamcrad(i,k)=0._r8 + pgamrad(i,k)=0._r8 + effc_fn(i,k) = 10._r8 + end if + enddo + enddo + ! recalculate 'final' rain size distribution parameters + ! to ensure that rain size is in bounds, adjust rain number if needed + do k=1,nlev + do i=1,mgncol + + if (dumr(i,k).ge.qsmall) then + + dum = dumnr(i,k) + + call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), & + lamr(i,k)) + + if (dum /= dumnr(i,k)) then + if (diag_id%rain_num_adj + diag_id%rain_num_adj_col > 0) & + diag_4l(:,j,:,diag_pt%rain_num_adj) = nrtend(i,k) + + ! adjust number conc if needed to keep mean size in reasonable range + nrtend(i,k)=(dumnr(i,k)*precip_frac(i,k)-nr(i,k))/deltat + + if (diag_id%rain_num_adj + diag_id%rain_num_adj_col > 0) & + diag_4l(:,j,:,diag_pt%rain_num_adj) = nrtend(i,k)-diag_4l(:,j,:,diag_pt%rain_num_adj) + + end if + + end if + enddo + enddo + ! recalculate 'final' snow size distribution parameters + ! to ensure that snow size is in bounds, adjust snow number if needed + do k=1,nlev + do i=1,mgncol + if (dums(i,k).ge.qsmall) then + + dum = dumns(i,k) + + call size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), & + lams(i,k), n0=dumns0) + + if (dum /= dumns(i,k)) then + if (diag_id%snow_num_adj + diag_id%snow_num_adj_col > 0) & + diag_4l(:,j,:,diag_pt%snow_num_adj) = nstend(i,k) + + ! adjust number conc if needed to keep mean size in reasonable range + nstend(i,k)=(dumns(i,k)*precip_frac(i,k)-ns(i,k))/deltat + + if (diag_id%snow_num_adj + diag_id%snow_num_adj_col > 0) & + diag_4l(:,j,:,diag_pt%snow_num_adj) = nstend(i,k)-diag_4l(:,j,:,diag_pt%snow_num_adj) + end if + + sadsnow(i,k) = 2._r8*pi*(lams(i,k)**(-3))*dumns0*rho(i,k)*1.e-2_r8 ! m2/m3 -> cm2/cm3 + + end if + + + end do ! vertical k loop + enddo + + ! DO STUFF FOR OUTPUT: + !================================================== + ! averaging for snow and rain number and diameter + !-------------------------------------------------- + + ! drout2/dsout2: + ! diameter of rain and snow + ! dsout: + ! scaled diameter of snow (passed to radiation in CAM) + ! reff_rain/reff_snow: + ! calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual + + where (qrout .gt. 1.e-7_r8 & + .and. nrout.gt.0._r8) + qrout2 = qrout * precip_frac + nrout2 = nrout * precip_frac + ! The avg_diameter call does the actual calculation; other diameter + ! outputs are just drout2 times constants. + drout2 = avg_diameter(qrout, nrout, rho, rhow) + freqr = precip_frac + + reff_rain=1.5_r8*drout2*1.e6_r8 + elsewhere + qrout2 = 0._r8 + nrout2 = 0._r8 + drout2 = 0._r8 + freqr = 0._r8 + reff_rain = 0._r8 + end where + + where (qsout .gt. 1.e-7_r8 & + .and. nsout.gt.0._r8) + qsout2 = qsout * precip_frac + nsout2 = nsout * precip_frac + ! The avg_diameter call does the actual calculation; other diameter + ! outputs are just dsout2 times constants. + dsout2 = avg_diameter(qsout, nsout, rho, rhosn) + freqs = precip_frac + + dsout=3._r8*rhosn/rhows*dsout2 + + reff_snow=1.5_r8*dsout2*1.e6_r8 + elsewhere + dsout = 0._r8 + qsout2 = 0._r8 + nsout2 = 0._r8 + dsout2 = 0._r8 + freqs = 0._r8 + reff_snow=0._r8 + end where + +!--> h1g, 2010-01-15, add limits for rain drop radius +#ifdef GFDL_COMPATIBLE_MICROP + reff_rain = max( 30.0_r8, reff_rain ) + reff_rain = min( 750.0_r8, reff_rain ) +#endif +!<-- h1g, 2010-01-15, add limits for rain drop radius + + + +#ifdef GFDL_COMPATIBLE_MICROP +! diagnostics for water tendencies +! water vapor specific humicity + + ! if (diag_id%qdt_cond > 0) & + ! diag_4l(:,j,:,diag_pt%qdt_cond) = -cmelo(:,:) + + if (diag_id%qdt_deposition > 0) & + diag_4l(:,j,:,diag_pt%qdt_deposition ) = -cmeitot( : , : ) + if (diag_id%qdt_sedi_ice2vapor> 0) & + diag_4l(:,j,:,diag_pt%qdt_sedi_ice2vapor) = qisevap( : , : ) + if (diag_id%qdt_sedi_liquid2vapor> 0) & + diag_4l(:,j,:,diag_pt%qdt_sedi_liquid2vapor) = qcsevap( : , : ) + if (diag_id%qdt_super_sat_rm > 0) & + diag_4l(:,j,:,diag_pt%qdt_super_sat_rm) = qvres( : , : ) + +! cloud liquid water + if (diag_id%qldt_accr + diag_id%ql_accr_col > 0) & + diag_4l(:,j,:,diag_pt%qldt_accr) = - pratot(:,:) + if (diag_id%qldt_auto + diag_id%ql_auto_col > 0)& + diag_4l(:,j,:,diag_pt%qldt_auto) = -prctot(:,:) + if (diag_id%qldt_freez2 + diag_id%ql_freez2_col > 0) & + diag_4l(:,j,:,diag_pt%qldt_freez2) = & + -(mnuccctot(:,:) + mnuccttot(:,:) ) + sum_freeze2(:,:) = mnuccctot(:,:) + mnuccttot(:,:) + if (diag_id%qldt_accrs + diag_id%ql_accrs_col > 0) & + diag_4l(:,j,:,diag_pt%qldt_accrs) = -psacwstot(:,:) + sum_rime(:,:) = psacwstot(:,:) + if (diag_id%qldt_HM_splinter + diag_id%ql_HM_splinter_col > 0)& + diag_4l(:,j,:,diag_pt%qldt_HM_splinter) = -msacwitot(:,:) + sum_splinter(:,:) = msacwitot(:,:) + if (diag_id%qldt_bergs + diag_id%ql_bergs_col > 0) & + diag_4l(:,j,:,diag_pt%qldt_bergs) = -bergstot(:,:) + sum_bergs(:,:) = bergstot (:,:) + + + if (diag_id%qidt_dep + diag_id%qi_dep_col > 0) & + diag_4l(:,j,:,diag_pt%qidt_dep) = max(cmeitot(:,:),0._r8) + if (diag_id%qidt_subl + diag_id%qi_subl_col > 0) & + diag_4l(:,j,:,diag_pt%qidt_subl) = - max(-1._r8*cmeitot(:,:),0._r8) + + sum_cond(:,:) = max(cmeitot(:,:),0._r8) + + if (diag_id%qldt_cond + diag_id%ql_cond_col > 0) & + diag_4l(:,j,:,diag_pt%qldt_cond) = max(cmelo(:,:), 0._r8) + if (diag_id%qldt_evap + diag_id%ql_evap_col > 0) & + diag_4l(:,j,:,diag_pt%qldt_evap) = & + - max(-1._r8*cmelo(:,:),0._r8) + + + if (diag_id%qldt_eros + diag_id%ql_eros_col > 0) & + diag_4l(:,j,:,diag_pt%qldt_eros) = eroslo(:,:) + if (diag_id%qdt_eros_l > 0) & + diag_4l(:,j,:,diag_pt%qdt_eros_l) = -eroslo(:,:) + + if (diag_id%qidt_eros + diag_id%qi_eros_col > 0) & + diag_4l(:,j,:,diag_pt%qidt_eros) = erosio(:,:) + if (diag_id%qdt_eros_i > 0) & + diag_4l(:,j,:,diag_pt%qdt_eros_i) = -erosio(:,:) + + + if (diag_id%qldt_berg + diag_id%ql_berg_col > 0) & + diag_4l(:,j,:,diag_pt%qldt_berg) = -bergtot(:,:) + sum_berg(:,:) = bergtot(:,:) + IF ( diag_id%qldt_sedi + diag_id%ql_sedi_col > 0 ) & + diag_4l(:,j,1:nlev,diag_pt%qldt_sedi) = qcsedten(:,:) + IF ( diag_id%liq_adj + diag_id%liq_adj_col > 0 ) & + diag_4l(:,j,:,diag_pt%liq_adj) = qcrestot(:,:) + +! cloud ice water + if (diag_id%qidt_auto + diag_id%qi_auto_col > 0) & + diag_4l(:,j,:,diag_pt%qidt_auto) = -prcitot(:,:) + if (diag_id%qidt_accr + diag_id%qi_accr_col > 0) & + diag_4l(:,j,:,diag_pt%qidt_accr) = -praitot(:,:) + if (diag_id%qidt_rain2ice + diag_id%qi_rain2ice_col > 0) & + diag_4l(:,j,:,diag_pt%qidt_rain2ice) = diag_4l(:,j,:,diag_pt%qidt_rain2ice) & + + mnuccritot(:,:) + IF ( diag_id%qidt_fall + diag_id%qi_fall_col > 0 ) & + diag_4l(:,j,1:nlev,diag_pt%qidt_fall) = qisedten(:,1:nlev) + IF ( diag_id%ice_adj + diag_id%ice_adj_col > 0 ) & + diag_4l(:,j,:,diag_pt%ice_adj) = qirestot(:,:) + sum_ice_adj(:,:) = qirestot(:,:) + +! ---> rain water mixing ratio + if (diag_id%srfrain_accrs + diag_id%srfrain_accrs_col > 0) & + diag_4l(:,j,:,diag_pt%srfrain_accrs) = diag_4l(:,j,:,diag_pt%srfrain_accrs) & + -pracstot(:,:) + if (diag_id%rain_freeze + diag_id%rain_freeze_col > 0) & + diag_4l(:,j,:,diag_pt%rain_freeze) = -mnuccrtot(:,:) + if (diag_id%rain_evap + diag_id%rain_evap_col > 0) & + diag_4l(:,j,:,diag_pt%rain_evap) = pre( : , : )*precip_frac(:,:) + if (diag_id%rain_sedi + diag_id%rain_sedi_col > 0) & + diag_4l(:,j,:,diag_pt%rain_sedi) = qrsedten(:,:) + +! ---> snow mixing ratio + if (diag_id%qdt_snow_sublim + diag_id%q_snow_sublim_col > 0 ) & + diag_4l(:,j,:,diag_pt%qdt_snow_sublim ) = -prds( : , : )*precip_frac(:,:) + if (diag_id%snow_sedi + diag_id%snow_sedi_col > 0) & + diag_4l(:,j,:,diag_pt%snow_sedi) = qssedten(:,:) + +! ---> rain number mixing ratio + if ( diag_id%rain_num2snow + diag_id%rain_num2snow_col > 0 ) & + diag_4l(:,j,:,diag_pt%rain_num2snow) = diag_4l(:,j,:,diag_pt%rain_num2snow) & + -npracs(:,:)*precip_frac(:,:) + if ( diag_id%rain_num_evap + diag_id%rain_num_evap_col > 0 ) & + diag_4l(:,j,:,diag_pt%rain_num_evap) = nsubr( : , : )*precip_frac(:,:) + + if ( diag_id%rain_num_freez + diag_id%rain_num_freez_col > 0 ) & + diag_4l(:,j,:,diag_pt%rain_num_freez) = -nnuccr( : , : )*precip_frac(:,:) + + +! --->liquid droplet number +! if ( diag_id%qndt_cond + diag_id%qn_cond_col > 0 ) & +! diag_4l(:,j,:,diag_pt%qndt_cond) = npccn2(:,:) + if (diag_id%qndt_cond + diag_id%qn_cond_col > 0) & + diag_4l(:,j,:,diag_pt%qndt_cond) = npccno(:,:) + if (diag_id%qndt_eros + diag_id%qn_eros_col > 0) & + diag_4l(:,j,:,diag_pt%qndt_eros) = nerosco(:,:) + if (diag_id%qndt_pra + diag_id%qn_pra_col > 0) & + diag_4l(:,j,:,diag_pt%qndt_pra) = nprao(:,:) + if (diag_id%qndt_auto + diag_id%qn_auto_col > 0) & + diag_4l(:,j,:,diag_pt%qndt_auto) = nprc1o(:,:) + if (diag_id%qndt_freez + diag_id%qn_freez_col > 0) & + diag_4l(:,j,:,diag_pt%qndt_freez) = nnuccco(:,:) + if (diag_id%qndt_contact_frz + diag_id%qn_contact_frz_col > 0) & + diag_4l(:,j,:,diag_pt%qndt_contact_frz) = nnuccto(:,:) + if (diag_id%qndt_sacws + diag_id%qn_sacws_col > 0) & + diag_4l(:,j,:,diag_pt%qndt_sacws) = npsacwso(:,:) + if (diag_id%qndt_evap + diag_id%qn_evap_col > 0) & + diag_4l(:,j,:,diag_pt%qndt_evap) = nsubco(:,:) + +! ---> ice number + if (diag_id%qnidt_nnuccd + diag_id%qni_nnuccd_col > 0) & + diag_4l(:,j,:,diag_pt%qnidt_nnuccd) = nnuccdo(:,:) + if (diag_id%qnidt_nsacwi> 0) & + diag_4l(:,j,:,diag_pt%qnidt_nsacwi) = nsacwio + + if (diag_id%qnidt_nsubi + diag_id%qni_nsubi_col > 0) & + diag_4l(:,j,:,diag_pt%qnidt_nsubi) = nsubio(:,:) + if (diag_id%qnidt_nerosi + diag_id%qni_nerosi_col > 0) & + diag_4l(:,j,:,diag_pt%qnidt_nerosi) = nerosio + if (diag_id%qnidt_auto + diag_id%qni_auto_col > 0) & + diag_4l(:,j,:,diag_pt%qnidt_auto) = nprcio + if (diag_id%qnidt_accr + diag_id%qni_accr_col > 0) & + diag_4l(:,j,:,diag_pt%qnidt_accr) = npraio + if (diag_id%qnidt_rain2ice + diag_id%qni_rain2ice_col > 0) & + diag_4l(:,j,:,diag_pt%qnidt_rain2ice) = diag_4l(:,j,:,diag_pt%qnidt_rain2ice) & + +nnuccrio + +!10/23/13: NOTE: STILL NEEDS CONVERSION !!!! +!RSH: +! calculate fraction of total ice / snow creation that requires +! ice-forming nuclei + do k=1,nlev + do i=1,mgncol + qldt_sum = sum_cond(i,k) + sum_rime(i,k) + sum_berg(i,k) + & + sum_ice_adj(i,k) + MAX(sum_bergs(i,k), 0.0) + & + sum_freeze(i,k) + sum_freeze2(i,k) + sum_splinter(i,k) + if ( ABS(qldt_sum) > 0.0 ) then +! ---> h1g, 2014-07-18, add option of including contact freeze in bergeron + if( include_contact_freeze_in_berg ) then + f_snow_berg(i,k) = (sum_berg(i,k) + sum_cond(i,k) + & + sum_ice_adj(i,k) + & + MAX( sum_bergs(i,k), 0.0) + & + sum_freeze (i,k) + sum_freeze2(i,k) )/qldt_sum + else + f_snow_berg(i,k) = (sum_berg(i,k) + sum_cond(i,k) + & + sum_ice_adj(i,k) + & + MAX( sum_bergs(i,k), 0.0) + & + sum_freeze (i,k) + mnuccctot(i,k) )/qldt_sum ! h1g 2015-06-05 + + endif +! <--- h1g, 2014-07-18 + else + f_snow_berg(i,k) = 0._r8 + endif + end do + end do + +#endif +end subroutine micro_mg2_tend + + +!======================================================================== +!OUTPUT CALCULATIONS +!======================================================================== + +subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol) + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: lamr ! rain size parameter (slope) + real(r8), dimension(mgncol), intent(in) :: n0r ! rain size parameter (intercept) + real(r8), dimension(mgncol), intent(in) :: lamc ! size distribution parameter (slope) + real(r8), dimension(mgncol), intent(in) :: pgam ! droplet size parameter + real(r8), dimension(mgncol), intent(in) :: qric ! in-cloud rain mass mixing ratio + real(r8), dimension(mgncol), intent(in) :: qcic ! in-cloud cloud liquid + real(r8), dimension(mgncol), intent(in) :: ncic ! in-cloud droplet number concentration + + real(r8), dimension(mgncol), intent(inout) :: rercld ! effective radius calculation for rain + cloud + + ! combined size of precip & cloud drops + real(r8) :: Atmp + + integer :: i + + do i=1,mgncol + ! Rain drops + if (lamr(i) > 0._r8) then + Atmp = n0r(i) * pi / (2._r8 * lamr(i)**3._r8) + else + Atmp = 0._r8 + end if + + ! Add cloud drops + if (lamc(i) > 0._r8) then + Atmp = Atmp + & + ncic(i) * pi * rising_factorial(pgam(i)+1._r8, 2)/(4._r8 * lamc(i)**2._r8) + end if + + if (Atmp > 0._r8) then + rercld(i) = rercld(i) + 3._r8 *(qric(i) + qcic(i)) / (4._r8 * rhow * Atmp) + end if + enddo +end subroutine calc_rercld + + +!======================================================================== +!UTILITIES +!======================================================================== + + subroutine micro_mg2_get_cols(ncol, nlev, top_lev, qcn, qin, & + qrn, qsn, mgncol, mgcols) + + ! Determines which columns microphysics should operate over by + ! checking for non-zero cloud water/ice. + + integer, intent(in) :: ncol ! Number of columns with meaningful data + integer, intent(in) :: nlev ! Number of levels to use + integer, intent(in) :: top_lev ! Top level for microphysics + + real(r8), intent(in) :: qcn(:,:) ! cloud water mixing ratio (kg/kg) + real(r8), intent(in) :: qin(:,:) ! cloud ice mixing ratio (kg/kg) + real(r8), intent(in) :: qrn(:,:) ! rain mixing ratio (kg/kg) + real(r8), intent(in) :: qsn(:,:) ! snow mixing ratio (kg/kg) + + integer, intent(out) :: mgncol ! Number of columns MG will use + integer, allocatable, intent(out) :: mgcols(:) ! column indices + + integer :: lev_offset ! top_lev - 1 (defined here for consistency) + logical :: ltrue(ncol) ! store tests for each column + + integer :: i, ii ! column indices + + if (allocated(mgcols)) deallocate(mgcols) + + lev_offset = top_lev - 1 + + ! Using "any" along dimension 2 collapses across levels, but + ! not columns, so we know if water is present at any level + ! in each column. + + ltrue = any(qcn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + ltrue = ltrue .or. any(qin(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + ltrue = ltrue .or. any(qrn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + ltrue = ltrue .or. any(qsn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + + ! Scan for true values to get a usable list of indices. + + mgncol = count(ltrue) + allocate(mgcols(mgncol)) + i = 0 + do ii = 1,ncol + if (ltrue(ii)) then + i = i + 1 + mgcols(i) = ii + end if + end do + +end subroutine micro_mg2_get_cols + + + + +! ======================================================================= +! time - implicit monotonic scheme +! developed by sj lin, 2016 +! ======================================================================= + +subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) + + implicit none + + integer, intent (in) :: ktop, kbot + + real(r8), intent (in) :: dt + + real(r8), intent (in), dimension (ktop:kbot + 1) :: ze + + real(r8), intent (in), dimension (ktop:kbot) :: vt, dp + + real(r8), intent (inout), dimension (ktop:kbot) :: q + + real(r8), intent (out), dimension (ktop:kbot) :: m1 + + real(r8), intent (out) :: precip + + real(r8), dimension (ktop:kbot) :: dz, qm, dd + + integer :: k + + do k = ktop, kbot + dz (k) = ze (k) - ze (k + 1) + dd (k) = dt * vt (k) + q (k) = q (k) * dp (k) + enddo + + ! ----------------------------------------------------------------------- + ! sedimentation: non - vectorizable loop + ! ----------------------------------------------------------------------- + + qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) + do k = ktop + 1, kbot + qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) + enddo + + ! ----------------------------------------------------------------------- + ! qm is density at this stage + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + qm (k) = qm (k) * dz (k) + enddo + + ! ----------------------------------------------------------------------- + ! output mass fluxes: non - vectorizable loop + ! ----------------------------------------------------------------------- + + m1 (ktop) = q (ktop) - qm (ktop) + do k = ktop + 1, kbot + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = m1 (kbot) + + ! ----------------------------------------------------------------------- + ! update: + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + q (k) = qm (k) / dp (k) + enddo + +end subroutine implicit_fall + + + + +end module micro_mg2_mod + diff --git a/atmos_param/microphysics/micro_mg2_utils.F90 b/atmos_param/microphysics/micro_mg2_utils.F90 new file mode 100644 index 00000000..e2e4a72e --- /dev/null +++ b/atmos_param/microphysics/micro_mg2_utils.F90 @@ -0,0 +1,1708 @@ +module micro_mg2_utils + +!-------------------------------------------------------------------------- +! +! This module contains process rates and utility functions used by the MG +! microphysics. +! +! Original MG authors: Andrew Gettelman, Hugh Morrison +! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan +! +! Separated from MG 1.5 by B. Eaton. +! Separated module switched to MG 2.0 and further changes by S. Santos. +! +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +! +!-------------------------------------------------------------------------- +! +! List of required external functions that must be supplied: +! gamma --> standard mathematical gamma function (if gamma is an +! intrinsic, define HAVE_GAMMA_INTRINSICS) +! +!-------------------------------------------------------------------------- +! +! Constants that must be specified in the "init" method (module variables): +! +! kind kind of reals (to verify correct linkage only) - +! gravit acceleration due to gravity m s-2 +! rair dry air gas constant for air J kg-1 K-1 +! rh2o gas constant for water vapor J kg-1 K-1 +! cpair specific heat at constant pressure for dry air J kg-1 K-1 +! tmelt temperature of melting point for water K +! latvap latent heat of vaporization J kg-1 +! latice latent heat of fusion J kg-1 +! +!-------------------------------------------------------------------------- + +use gamma_mg_mod, only: gamma =>gamma_mg + +implicit none +private +save + +public :: & + micro_mg_utils_init, & + size_dist_param_liq, & + size_dist_param_basic, & + avg_diameter, & + rising_factorial, & + ice_deposition_sublimation, & + sb2001v2_liq_autoconversion,& + sb2001v2_accre_cld_water_rain,& + kk2000_liq_autoconversion, & + ice_autoconversion, & + immersion_freezing, & + contact_freezing, & + 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, & + evaporate_sublimate_precip, & + bergeron_process_snow, & ! h1g, 2020-03-23 + cotton_liq_autoconversion ! h1g, 2020-03-23 + + +! 8 byte real and integer +integer, parameter, public :: r8 = selected_real_kind(12) +integer, parameter, public :: i8 = selected_int_kind(18) + +public :: MGHydrometeorProps + +type :: MGHydrometeorProps + ! Density (kg/m^3) + real(r8) :: rho + ! Information for size calculations. + ! Basic calculation of mean size is: + ! lambda = (shape_coef*nic/qic)^(1/eff_dim) + ! Then lambda is constrained by bounds. + real(r8) :: eff_dim + real(r8) :: shape_coef + real(r8) :: lambda_bounds(2) + ! Minimum average particle mass (kg). + ! Limit is applied at the beginning of the size distribution calculations. + real(r8) :: min_mean_mass +end type MGHydrometeorProps + +interface MGHydrometeorProps + module procedure NewMGHydrometeorProps +end interface + +type(MGHydrometeorProps), public :: mg_liq_props +type(MGHydrometeorProps), public :: mg_ice_props +type(MGHydrometeorProps), public :: mg_rain_props +type(MGHydrometeorProps), public :: mg_snow_props + +interface size_dist_param_liq + module procedure size_dist_param_liq_vect + module procedure size_dist_param_liq_line +end interface +interface size_dist_param_basic + module procedure size_dist_param_basic_vect + module procedure size_dist_param_basic_line +end interface + +!================================================= +! Public module parameters (mostly for MG itself) +!================================================= + +! Pi to 20 digits; more than enough to reach the limit of double precision. +real(r8), parameter, public :: pi = 3.14159265358979323846_r8 + +! "One minus small number": number near unity for round-off issues. +real(r8), parameter, public :: omsm = 1._r8 - 1.e-5_r8 + +! Smallest mixing ratio considered in microphysics. +real(r8), parameter, public :: qsmall = 1.e-18_r8 + +! minimum allowed cloud fraction +real(r8), parameter, public :: mincld = 0.0001_r8 + +!--> h1g-2020-02-20 save the CAM default values +!real(r8), parameter, public :: rhosn = 250._r8 ! bulk density snow +real(r8), parameter, public :: rhosn = 250._r8 ! bulk density snow +!<-- h1g-2020-02-20 + +real(r8), parameter, public :: rhoi = 500._r8 ! bulk density ice +real(r8), parameter, public :: rhow = 1000._r8 ! bulk density liquid +real(r8), parameter, public :: rhows = 917._r8 ! bulk density water solid + +! fall speed parameters, V = aD^b (V is in m/s) +! droplets +real(r8), parameter, public :: ac = 3.e7_r8 +real(r8), parameter, public :: bc = 2._r8 +! snow +real(r8), parameter, public :: as = 11.72_r8 +real(r8), parameter, public :: bs = 0.41_r8 +! cloud ice +real(r8), parameter, public :: ai = 700._r8 +real(r8), parameter, public :: bi = 1._r8 +! small cloud ice (r< 10 um) - sphere, bulk density +real(r8), parameter, public :: aj = ac*((rhoi/rhows)**(bc/3._r8))*rhows/rhow +real(r8), parameter, public :: bj = bc +! rain +real(r8), parameter, public :: ar = 841.99667_r8 +real(r8), parameter, public :: br = 0.8_r8 + +! mass of new crystal due to aerosol freezing and growth (kg) +! Make this consistent with the lower bound, to support UTLS and +! stratospheric ice, and the smaller ice size limit. +real(r8), parameter, public :: mi0 = 4._r8/3._r8*pi*rhoi*(1.e-6_r8)**3 + +!================================================= +! Private module parameters +!================================================= + +! Signaling NaN bit pattern that represents a limiter that's turned off. +integer(i8), parameter :: limiter_off = int(Z'7FF1111111111111', i8) + +! alternate threshold used for some in-cloud mmr +real(r8), parameter :: icsmall = 1.e-8_r8 + +! particle mass-diameter relationship +! currently we assume spherical particles for cloud ice/snow +! m = cD^d +! exponent +real(r8), parameter :: dsph = 3._r8 + +! Bounds for mean diameter for different constituents. +real(r8), parameter :: lam_bnd_rain(2) = 1._r8/[500.e-6_r8, 20.e-6_r8] +!real(r8), parameter :: lam_bnd_snow(2) = 1._r8/[2000.e-6_r8, 10.e-6_r8] ! h1g, 2020-07-30 + +! Minimum average mass of particles. +real(r8), parameter :: min_mean_mass_liq = 1.e-20_r8 +real(r8), parameter :: min_mean_mass_ice = 1.e-20_r8 + +! ventilation parameters +! for snow +real(r8), parameter :: f1s = 0.86_r8 +real(r8), parameter :: f2s = 0.28_r8 +! for rain +real(r8), parameter :: f1r = 0.78_r8 +real(r8), parameter :: f2r = 0.308_r8 + +! collection efficiencies +! aggregation of cloud ice and snow +real(r8), parameter :: eii = 0.5_r8 + + +! immersion freezing parameters, bigg 1953 +real(r8), parameter :: bimm = 100._r8 +real(r8), parameter :: aimm = 0.66_r8 + +! Mass of each raindrop created from autoconversion. +real(r8), parameter :: droplet_mass_25um = 4._r8/3._r8*pi*rhow*(25.e-6_r8)**3 +real(r8), parameter :: droplet_mass_40um = 4._r8/3._r8*pi*rhow*(40.e-6_r8)**3 + +!========================================================= +! Constants set in initialization +!========================================================= + +! Set using arguments to micro_mg_init +real(r8) :: rv ! water vapor gas constant +real(r8) :: cpp ! specific heat of dry air +real(r8) :: tmelt ! freezing point of water (K) + +! latent heats of: +real(r8) :: xxlv ! vaporization +real(r8) :: xlf ! freezing +real(r8) :: xxls ! sublimation + +! additional constants to help speed up code +real(r8) :: gamma_bs_plus3 +real(r8) :: gamma_half_br_plus5 +real(r8) :: gamma_half_bs_plus5 + +!========================================================= +! Utilities that are cheaper if the compiler knows that +! some argument is an integer. +!========================================================= + +interface rising_factorial + module procedure rising_factorial_r8 + module procedure rising_factorial_integer +end interface rising_factorial + +interface var_coef + module procedure var_coef_r8 + module procedure var_coef_integer +end interface var_coef + +!========================================================================== +contains +!========================================================================== + +! Initialize module variables. +! +! "kind" serves no purpose here except to check for unlikely linking +! issues; always pass in the kind for a double precision real. +! +! "errstring" is the only output; it is blank if there is no error, or set +! to a message if there is an error. +! +! Check the list at the top of this module for descriptions of all other +! arguments. +subroutine micro_mg_utils_init( kind, rh2o, cpair, tmelt_in, latvap, & + latice, dcs, errstring) + + integer, intent(in) :: kind + real(r8), intent(in) :: rh2o + real(r8), intent(in) :: cpair + real(r8), intent(in) :: tmelt_in + real(r8), intent(in) :: latvap + real(r8), intent(in) :: latice + real(r8), intent(in) :: dcs + + character(128), intent(out) :: errstring + + ! Name this array to workaround an XLF bug (otherwise could just use the + ! expression that sets it). + real(r8) :: ice_lambda_bounds(2) + real(r8) :: lam_bnd_snow(2) ! h1g, 2020-07-30 + !----------------------------------------------------------------------- + + errstring = ' ' + + if( kind .ne. r8 ) then + errstring = 'micro_mg_init: KIND of reals does not match' + return + endif + + ! declarations for MG code (transforms variable names) + + rv= rh2o ! water vapor gas constant + cpp = cpair ! specific heat of dry air + tmelt = tmelt_in + + ! latent heats + + xxlv = latvap ! latent heat vaporization + xlf = latice ! latent heat freezing + xxls = xxlv + xlf ! latent heat of sublimation + + ! Define constants to help speed up code (this limits calls to gamma function) + gamma_bs_plus3=gamma(3._r8+bs) + gamma_half_br_plus5=gamma(5._r8/2._r8+br/2._r8) + gamma_half_bs_plus5=gamma(5._r8/2._r8+bs/2._r8) + + ! Don't specify lambda bounds for cloud liquid, as they are determined by + ! pgam dynamically. + mg_liq_props = MGHydrometeorProps(rhow, dsph, & + min_mean_mass=min_mean_mass_liq) + + ! Mean ice diameter can not grow bigger than twice the autoconversion + ! threshold for snow. + ice_lambda_bounds = 1._r8/[2._r8*dcs, 1.e-6_r8] + + lam_bnd_snow = 1._r8/[2000.e-6_r8, 2._r8*dcs] ! h1g, 2020-07-30 +! lam_bnd_snow = 1._r8/[5000.e-6_r8, 2._r8*dcs] ! h1g, 2020-08-08 + + mg_ice_props = MGHydrometeorProps(rhoi, dsph, & + ice_lambda_bounds, min_mean_mass_ice) + + mg_rain_props = MGHydrometeorProps(rhow, dsph, lam_bnd_rain) + mg_snow_props = MGHydrometeorProps(rhosn, dsph, lam_bnd_snow) + +end subroutine micro_mg_utils_init + +! Constructor for a constituent property object. +function NewMGHydrometeorProps(rho, eff_dim, lambda_bounds, min_mean_mass) & + result(res) + real(r8), intent(in) :: rho, eff_dim + real(r8), intent(in), optional :: lambda_bounds(2), min_mean_mass + type(MGHydrometeorProps) :: res + + res%rho = rho + res%eff_dim = eff_dim + if (present(lambda_bounds)) then + res%lambda_bounds = lambda_bounds + else + res%lambda_bounds = no_limiter() + end if + if (present(min_mean_mass)) then + res%min_mean_mass = min_mean_mass + else + res%min_mean_mass = no_limiter() + end if + + res%shape_coef = rho*pi*gamma(eff_dim+1._r8)/6._r8 + +end function NewMGHydrometeorProps + +!======================================================================== +!FORMULAS +!======================================================================== + +! Use gamma function to implement rising factorial extended to the reals. +function rising_factorial_r8(x, n) result(res) + real(r8), intent(in) :: x, n + real(r8) :: res + + res = gamma(x+n)/gamma(x) + +end function rising_factorial_r8 + +! Rising factorial can be performed much cheaper if n is a small integer. +function rising_factorial_integer(x, n) result(res) + real(r8), intent(in) :: x + integer, intent(in) :: n + real(r8) :: res + + integer :: i + real(r8) :: factor + + res = 1._r8 + factor = x + + do i = 1, n + res = res * factor + factor = factor + 1._r8 + end do + +end function rising_factorial_integer + +! Calculate correction due to latent heat for evaporation/sublimation +elemental function calc_ab(t, qv, xxl) result(ab) + real(r8), intent(in) :: t ! Temperature + real(r8), intent(in) :: qv ! Saturation vapor pressure + real(r8), intent(in) :: xxl ! Latent heat + + real(r8) :: ab + + real(r8) :: dqsdt + + dqsdt = xxl*qv / (rv * t**2) + ab = 1._r8 + dqsdt*xxl/cpp + +end function calc_ab + +! get cloud droplet size distribution parameters +subroutine size_dist_param_liq_line(props, qcic, ncic, rho, pgam, lamc) + type(MGHydrometeorProps), intent(in) :: props + real(r8), intent(in) :: qcic + real(r8), intent(inout) :: ncic + real(r8), intent(in) :: rho + + real(r8), intent(out) :: pgam + real(r8), intent(out) :: lamc + + type(MGHydrometeorProps) :: props_loc + + if (qcic > qsmall) then + + ! Local copy of properties that can be modified. + ! (Elemental routines that operate on arrays can't modify scalar + ! arguments.) + props_loc = props + + ! Get pgam from fit to observations of martin et al. 1994 + pgam = 1.0_r8 - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic*rho) + pgam = 1._r8/(pgam**2) - 1._r8 + pgam = max(pgam, 2._r8) + + ! Set coefficient for use in size_dist_param_basic. + ! The 3D case is so common and optimizable that we specialize it: + if (props_loc%eff_dim == 3._r8) then + props_loc%shape_coef = pi / 6._r8 * props_loc%rho * & + ! rising_factorial(pgam+1._r8, 3) + gamma(pgam+4._r8)/gamma(pgam+1._r8) ! h1g, 2016-12-09 + else + props_loc%shape_coef = pi / 6._r8 * props_loc%rho * & + ! rising_factorial(pgam+1._r8, props_loc%eff_dim) + gamma(pgam+1._r8+props_loc%eff_dim)/gamma(pgam+1._r8) ! h1g, 2016-12-09 + end if + + ! Limit to between 2 and 50 microns mean size. + props_loc%lambda_bounds = (pgam+1._r8)*1._r8/[50.e-6_r8, 2.e-6_r8] + + call size_dist_param_basic(props_loc, qcic, ncic, lamc) + + else + ! pgam not calculated in this case, so set it to a value likely to + ! cause an error if it is accidentally used + ! (gamma function undefined for negative integers) + pgam = -100._r8 + lamc = 0._r8 + end if + +end subroutine size_dist_param_liq_line + +! get cloud droplet size distribution parameters + +subroutine size_dist_param_liq_vect(props, qcic, ncic, rho, pgam, lamc, mgncol) + + type(mghydrometeorprops), intent(in) :: props + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: qcic + real(r8), dimension(mgncol), intent(inout) :: ncic + real(r8), dimension(mgncol), intent(in) :: rho + real(r8), dimension(mgncol), intent(out) :: pgam + real(r8), dimension(mgncol), intent(out) :: lamc + type(mghydrometeorprops) :: props_loc + integer :: i + + do i=1,mgncol + if (qcic(i) > qsmall) then + ! Local copy of properties that can be modified. + ! (Elemental routines that operate on arrays can't modify scalar + ! arguments.) + props_loc = props + ! Get pgam from fit to observations of martin et al. 1994 + pgam(i) = 1.0_r8 - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic(i)*rho(i)) + pgam(i) = 1._r8/(pgam(i)**2) - 1._r8 + pgam(i) = max(pgam(i), 2._r8) + endif + enddo + do i=1,mgncol + if (qcic(i) > qsmall) then + ! Set coefficient for use in size_dist_param_basic. + ! The 3D case is so common and optimizable that we specialize + ! it: + if (props_loc%eff_dim == 3._r8) then + props_loc%shape_coef = pi / 6._r8 * props_loc%rho * & + ! rising_factorial(pgam(i)+1._r8, 3) + gamma(pgam(i)+4._r8)/gamma(pgam(i)+1._r8) ! h1g 2016-12-09 + else + props_loc%shape_coef = pi / 6._r8 * props_loc%rho * & + ! rising_factorial(pgam(i)+1._r8, props_loc%eff_dim) + gamma(pgam(i)+1._r8+props_loc%eff_dim)/gamma(pgam(i)+1._r8) ! h1g 2016-12-09 + end if + ! Limit to between 2 and 50 microns mean size. + props_loc%lambda_bounds(1) = (pgam(i)+1._r8)*1._r8/50.e-6_r8 + props_loc%lambda_bounds(2) = (pgam(i)+1._r8)*1._r8/2.e-6_r8 + call size_dist_param_basic(props_loc, qcic(i), ncic(i), lamc(i)) + endif + enddo + do i=1,mgncol + if (qcic(i) <= qsmall) then + ! pgam not calculated in this case, so set it to a value likely to + ! cause an error if it is accidentally used + ! (gamma function undefined for negative integers) + pgam(i) = -100._r8 + lamc(i) = 0._r8 + end if + enddo + +end subroutine size_dist_param_liq_vect + +! Basic routine for getting size distribution parameters. +elemental subroutine size_dist_param_basic_line(props, qic, nic, lam, n0) + type(MGHydrometeorProps), intent(in) :: props + real(r8), intent(in) :: qic + real(r8), intent(inout) :: nic + + real(r8), intent(out) :: lam + real(r8), intent(out), optional :: n0 + + if (qic > qsmall) then + + ! add upper limit to in-cloud number concentration to prevent + ! numerical error + if (limiter_is_on(props%min_mean_mass)) then + nic = min(nic, qic / props%min_mean_mass) + end if + + ! lambda = (c n/q)^(1/d) + lam = (props%shape_coef * nic/qic)**(1._r8/props%eff_dim) + + ! check for slope + ! adjust vars + if (lam < props%lambda_bounds(1)) then + lam = props%lambda_bounds(1) + nic = lam**(props%eff_dim) * qic/props%shape_coef + else if (lam > props%lambda_bounds(2)) then + lam = props%lambda_bounds(2) + nic = lam**(props%eff_dim) * qic/props%shape_coef + end if + + else + lam = 0._r8 + end if + + if (present(n0)) n0 = nic * lam + +end subroutine size_dist_param_basic_line + +subroutine size_dist_param_basic_vect(props, qic, nic, lam, mgncol, n0) + + type (mghydrometeorprops), intent(in) :: props + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: qic + real(r8), dimension(mgncol), intent(inout) :: nic + real(r8), dimension(mgncol), intent(out) :: lam + real(r8), dimension(mgncol), intent(out), optional :: n0 + integer :: i + do i=1,mgncol + + if (qic(i) > qsmall) then + + ! add upper limit to in-cloud number concentration to prevent + ! numerical error + if (limiter_is_on(props%min_mean_mass)) then + nic(i) = min(nic(i), qic(i) / props%min_mean_mass) + end if + + ! lambda = (c n/q)^(1/d) + lam(i) = (props%shape_coef * nic(i)/qic(i))**(1._r8/props%eff_dim) + + ! check for slope + ! adjust vars + if (lam(i) < props%lambda_bounds(1)) then + lam(i) = props%lambda_bounds(1) + nic(i) = lam(i)**(props%eff_dim) * qic(i)/props%shape_coef + else if (lam(i) > props%lambda_bounds(2)) then + lam(i) = props%lambda_bounds(2) + nic(i) = lam(i)**(props%eff_dim) * qic(i)/props%shape_coef + end if + + else + lam(i) = 0._r8 + end if + + enddo + + if (present(n0)) n0 = nic * lam + +end subroutine size_dist_param_basic_vect + + +real(r8) elemental function avg_diameter(q, n, rho_air, rho_sub) + ! Finds the average diameter of particles given their density, and + ! mass/number concentrations in the air. + ! Assumes that diameter follows an exponential distribution. + real(r8), intent(in) :: q ! mass mixing ratio + real(r8), intent(in) :: n ! number concentration (per volume) + real(r8), intent(in) :: rho_air ! local density of the air + real(r8), intent(in) :: rho_sub ! density of the particle substance + + avg_diameter = (pi * rho_sub * n/(q*rho_air))**(-1._r8/3._r8) + +end function avg_diameter + +function var_coef_r8(relvar, a) result(res) + ! Finds a coefficient for process rates based on the relative variance + ! of cloud water. + real(r8), intent(in) :: relvar + real(r8), intent(in) :: a + real(r8) :: res + +! res = rising_factorial(relvar, a) / relvar**a + res = gamma(relvar+a)/gamma(relvar)/ relvar**a ! h1g, 2016-12-09 + +end function var_coef_r8 + +function var_coef_integer(relvar, a) result(res) + ! Finds a coefficient for process rates based on the relative variance + ! of cloud water. + real(r8), intent(in) :: relvar + integer, intent(in) :: a + real(r8) :: res + +! res = rising_factorial(relvar, a) / relvar**a + res = gamma(relvar+a)/gamma(relvar)/ relvar**a ! h1g, 2016-12-09 + +end function var_coef_integer + +!======================================================================== +!MICROPHYSICAL PROCESS CALCULATIONS +!======================================================================== +!======================================================================== +! Initial ice deposition and sublimation loop. +! Run before the main loop +! This subroutine written by Peter Caldwell + +subroutine ice_deposition_sublimation(t, qv, qc, qi, ni, & ! h1g 2020-03-31 + icldm, rho, dv,qvl, qvi, & + berg, vap_dep, ice_sublim, mgncol) + + !INPUT VARS: + !=============================================== + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t + real(r8), dimension(mgncol), intent(in) :: qv + real(r8), dimension(mgncol), intent(in) :: qc ! h1g 2020-03-31 + real(r8), dimension(mgncol), intent(in) :: qi + real(r8), dimension(mgncol), intent(in) :: ni + real(r8), dimension(mgncol), intent(in) :: icldm + real(r8), dimension(mgncol), intent(in) :: rho + real(r8), dimension(mgncol), intent(in) :: dv + real(r8), dimension(mgncol), intent(in) :: qvl + real(r8), dimension(mgncol), intent(in) :: qvi + + !OUTPUT VARS: + !=============================================== + real(r8), dimension(mgncol), intent(out) :: vap_dep !ice deposition (cell-ave value) + real(r8), dimension(mgncol), intent(out) :: ice_sublim !ice sublimation (cell-ave value) + real(r8), dimension(mgncol), intent(out) :: berg !bergeron enhancement (cell-ave value) + + !INTERNAL VARS: + !=============================================== + real(r8) :: ab + real(r8) :: epsi + real(r8) :: qiic + real(r8) :: niic + real(r8) :: lami + real(r8) :: n0i + integer :: i + + do i=1,mgncol + if (qi(i)>=qsmall) then + + !GET IN-CLOUD qi, ni + !=============================================== + qiic = qi(i)/icldm(i) + niic = ni(i)/icldm(i) + + !Compute linearized condensational heating correction + ab=calc_ab(t(i), qvi(i), xxls) + !Get slope and intercept of gamma distn for ice. + call size_dist_param_basic(mg_ice_props, qiic, niic, lami, n0i) + !Get depletion timescale=1/eps + epsi = 2._r8*pi*n0i*rho(i)*Dv(i)/(lami*lami) + + !Compute deposition/sublimation + vap_dep(i) = epsi/ab*(qv(i) - qvi(i)) + + !Make this a grid-averaged quantity + vap_dep(i)=vap_dep(i)*icldm(i) + + !Split into deposition or sublimation. + if (t(i) < tmelt .and. vap_dep(i)>0._r8) then + ice_sublim(i)=0._r8 + else + ! make ice_sublim negative for consistency with other evap/sub processes + ice_sublim(i)=min(vap_dep(i),0._r8) + vap_dep(i)=0._r8 + end if + + !sublimation occurs @ any T. Not so for berg. + if ( t(i)>tmelt-40.0 .and. t(i)qsmall ) then ! h1g 2020-06-25 + + !Compute bergeron rate assuming cloud for whole step. + berg(i) = max(epsi/ab*(qvl(i) - qvi(i)), 0._r8) + berg(i) = berg(i) * icldm(i) + else !T>frz + berg(i)=0._r8 + end if !Tqsmall + enddo +end subroutine ice_deposition_sublimation + + +!======================================================================== +! autoconversion of cloud liquid water to rain +! formula from Manton and Cotton (1977). +! This formula has been used in Chen and Cotton (1987), +! modified for sub-grid distribution of qc +! minimum qc of 1 x 10^-8 prevents floating point error + +subroutine cotton_liq_autoconversion(microp_uniform, qcic, & + ncic, rho, relvar, rthresh, prc, nprc, nprc1, mgncol) + + integer, intent(in) :: mgncol + logical, intent(in) :: microp_uniform + + real(r8), intent(in) :: rthresh + + real(r8), dimension(mgncol), intent(in) :: qcic + real(r8), dimension(mgncol), intent(in) :: ncic + real(r8), dimension(mgncol), intent(in) :: rho + + real(r8), dimension(mgncol), intent(in) :: relvar + + real(r8), dimension(mgncol), intent(out) :: prc + real(r8), dimension(mgncol), intent(out) :: nprc + real(r8), dimension(mgncol), intent(out) :: nprc1 + + real(r8), dimension(mgncol) :: prc_coef + integer :: i + real(r8) :: rad_liq + + ! Take variance into account, or use uniform value. + if (.not. microp_uniform) then + ! prc_coef(:) = var_coef(relvar(:), 2.47_r8) + do i=1,mgncol + prc_coef(i) = gamma(relvar(i)+2.33_r8)/gamma(relvar(i))/ relvar(i)**2.33 ! h1g, 2016-12-09 + enddo + else + prc_coef(:) = 1._r8 + end if + + do i=1,mgncol + rad_liq = 620350.49* (qcic(i)/max(ncic(i),icsmall)/rhow)**(0.33_r8) + if (qcic(i) >= icsmall .and. rad_liq > rthresh ) then + + ! nprc is increase in rain number conc due to autoconversion + ! nprc1 is decrease in cloud droplet conc due to autoconversion + + ! assume exponential sub-grid distribution of qc, resulting in additional + ! factor related to qcvar below + ! switch for sub-columns, don't include sub-grid qc + + prc(i) = prc_coef(i) * & + 32681. * qcic(i)**2.33_r8 * (ncic(i)*rho(i)*rhow)**(-0.33_r8) + nprc(i) = prc(i) * (1._r8/droplet_mass_25um) + nprc1(i) = prc(i)*ncic(i)/qcic(i) + + else + prc(i)=0._r8 + nprc(i)=0._r8 + nprc1(i)=0._r8 + end if + enddo +end subroutine cotton_liq_autoconversion + + +!======================================================================== +! autoconversion of cloud liquid water to rain +! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc +! minimum qc of 1 x 10^-8 prevents floating point error + +subroutine kk2000_liq_autoconversion(microp_uniform, qcic, & + ncic, rho, relvar, prc, nprc, nprc1, mgncol) + + integer, intent(in) :: mgncol + logical, intent(in) :: microp_uniform + + real(r8), dimension(mgncol), intent(in) :: qcic + real(r8), dimension(mgncol), intent(in) :: ncic + real(r8), dimension(mgncol), intent(in) :: rho + + real(r8), dimension(mgncol), intent(in) :: relvar + + real(r8), dimension(mgncol), intent(out) :: prc + real(r8), dimension(mgncol), intent(out) :: nprc + real(r8), dimension(mgncol), intent(out) :: nprc1 + + real(r8), dimension(mgncol) :: prc_coef + integer :: i + + ! Take variance into account, or use uniform value. + if (.not. microp_uniform) then + ! prc_coef(:) = var_coef(relvar(:), 2.47_r8) + do i=1,mgncol + prc_coef(i) = gamma(relvar(i)+2.47_r8)/gamma(relvar(i))/ relvar(i)**2.47 ! h1g, 2016-12-09 + enddo + else + prc_coef(:) = 1._r8 + end if + + do i=1,mgncol + if (qcic(i) >= icsmall) then + + ! nprc is increase in rain number conc due to autoconversion + ! nprc1 is decrease in cloud droplet conc due to autoconversion + + ! assume exponential sub-grid distribution of qc, resulting in additional + ! factor related to qcvar below + ! switch for sub-columns, don't include sub-grid qc + + prc(i) = prc_coef(i) * & + 0.01_r8 * 1350._r8 * qcic(i)**2.47_r8 * (ncic(i)*1.e-6_r8*rho(i))**(-1.1_r8) + nprc(i) = prc(i) * (1._r8/droplet_mass_25um) + nprc1(i) = prc(i)*ncic(i)/qcic(i) + + else + prc(i)=0._r8 + nprc(i)=0._r8 + nprc1(i)=0._r8 + end if + enddo +end subroutine kk2000_liq_autoconversion + + !======================================================================== +subroutine sb2001v2_liq_autoconversion(pgam,qc,nc,qr,rho,relvar,au,nprc,nprc1,mgncol) + ! + ! --------------------------------------------------------------------- + ! AUTO_SB: calculates the evolution of mass- and number mxg-ratio for + ! drizzle drops due to autoconversion. The autoconversion rate assumes + ! f(x)=A*x**(nu_c)*exp(-Bx) in drop MASS x. + + ! Code from Hugh Morrison, Sept 2014 + + ! autoconversion + ! use simple lookup table of dnu values to get mass spectral shape parameter + ! equivalent to the size spectral shape parameter pgam + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent (in) :: pgam + real(r8), dimension(mgncol), intent (in) :: qc ! = qc (cld water mixing ratio) + real(r8), dimension(mgncol), intent (in) :: nc ! = nc (cld water number conc /kg) + real(r8), dimension(mgncol), intent (in) :: qr ! = qr (rain water mixing ratio) + real(r8), dimension(mgncol), intent (in) :: rho ! = rho : density profile + real(r8), dimension(mgncol), intent (in) :: relvar + + real(r8), dimension(mgncol), intent (out) :: au ! = prc autoconversion rate + real(r8), dimension(mgncol), intent (out) :: nprc1 ! = number tendency + real(r8), dimension(mgncol), intent (out) :: nprc ! = number tendency fixed size for rain + + ! parameters for droplet mass spectral shape, + !used by Seifert and Beheng (2001) + ! warm rain scheme only (iparam = 1) + real(r8), parameter :: dnu(16) = [0._r8,-0.557_r8,-0.430_r8,-0.307_r8, & + -0.186_r8,-0.067_r8,0.050_r8,0.167_r8,0.282_r8,0.397_r8,0.512_r8, & + 0.626_r8,0.739_r8,0.853_r8,0.966_r8,0.966_r8] + + ! parameters for Seifert and Beheng (2001) autoconversion/accretion + real(r8), parameter :: kc = 9.44e9_r8 + real(r8), parameter :: kr = 5.78e3_r8 + real(r8) :: dum, dum1, nu, pra_coef + integer :: dumi, i + + do i=1,mgncol + + pra_coef = var_coef(relvar(i), 4._r8) + + if (qc(i) > qsmall) then + dumi=int(pgam(i)) + nu=dnu(dumi)+(dnu(dumi+1)-dnu(dumi))* & + (pgam(i)-dumi) + + dum = 1._r8-qc(i)/(qc(i)+qr(i)) + dum1 = 600._r8*dum**0.68_r8*(1._r8-dum**0.68_r8)**3 + + au(i) = pra_coef * kc/(20._r8*2.6e-7_r8)* & + (nu+2._r8)*(nu+4._r8)/(nu+1._r8)**2._r8* & + (rho(i)*qc(i)/1000._r8)**4._r8/(rho(i)*nc(i)/1.e6_r8)**2._r8* & + (1._r8+dum1/(1._r8-dum)**2)*1000._r8 / rho(i) + + nprc1(i) = au(i)*2._r8/2.6e-7_r8*1000._r8 + nprc(i) = au(i)/droplet_mass_40um + else + au(i) = 0._r8 + nprc1(i) = 0._r8 + nprc(i)=0._r8 + end if + + enddo + + end subroutine sb2001v2_liq_autoconversion + +!======================================================================== +!SB2001 Accretion V2 + +subroutine sb2001v2_accre_cld_water_rain(qc,nc,qr,rho,relvar,pra,npra,mgncol) + ! + ! --------------------------------------------------------------------- + ! ACCR_SB calculates the evolution of mass mxng-ratio due to accretion + ! and self collection following Seifert & Beheng (2001). + ! + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent (in) :: qc ! = qc (cld water mixing ratio) + real(r8), dimension(mgncol), intent (in) :: nc ! = nc (cld water number conc /kg) + real(r8), dimension(mgncol), intent (in) :: qr ! = qr (rain water mixing ratio) + real(r8), dimension(mgncol), intent (in) :: rho ! = rho : density profile + real(r8), dimension(mgncol), intent (in) :: relvar + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: pra ! MMR + real(r8), dimension(mgncol), intent(out) :: npra ! Number + + ! parameters for Seifert and Beheng (2001) autoconversion/accretion + real(r8), parameter :: kc = 9.44e9_r8 + real(r8), parameter :: kr = 5.78e3_r8 + + real(r8) :: dum, dum1, pra_coef + integer :: i + + ! accretion + + do i =1,mgncol + + pra_coef = var_coef(relvar(i), 1._r8) + + if (qc(i) > qsmall) then + dum = 1._r8-qc(i)/(qc(i)+qr(i)) + dum1 = (dum/(dum+5.e-4_r8))**4._r8 + pra(i) = pra_coef *kr*rho(i)*0.001_r8*qc(i)*qr(i)*dum1 + npra(i) = pra(i)*rho(i)*0.001_r8*(nc(i)*rho(i)*1.e-6_r8)/ & + (qc(i)*rho(i)*0.001_r8)*1.e6_r8 / rho(i) + else + pra(i) = 0._r8 + npra(i) = 0._r8 + end if + + enddo + + end subroutine sb2001v2_accre_cld_water_rain + +!======================================================================== +! Autoconversion of cloud ice to snow +! similar to Ferrier (1994) + +subroutine ice_autoconversion(t, qiic, lami, n0i, dcs, prci, nprci, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t + real(r8), dimension(mgncol), intent(in) :: qiic + real(r8), dimension(mgncol), intent(in) :: lami + real(r8), dimension(mgncol), intent(in) :: n0i + real(r8), intent(in) :: dcs + + real(r8), dimension(mgncol), intent(out) :: prci + real(r8), dimension(mgncol), intent(out) :: nprci + + ! Assume autoconversion timescale of 180 seconds. + real(r8), parameter :: ac_time = 180._r8 + + ! Average mass of an ice particle. + real(r8) :: m_ip + ! Ratio of autoconversion diameter to average diameter. + real(r8) :: d_rat + integer :: i + + do i=1,mgncol + if (t(i) <= tmelt .and. qiic(i) >= qsmall) then + + d_rat = lami(i)*dcs + + ! Rate of ice particle conversion (number). + nprci(i) = n0i(i)/(lami(i)*ac_time)*exp(-d_rat) + + m_ip = (rhoi*pi/6._r8) / lami(i)**3 + + ! Rate of mass conversion. + ! Note that this is: + ! m n (d^3 + 3 d^2 + 6 d + 6) + prci(i) = m_ip * nprci(i) * & + (((d_rat + 3._r8)*d_rat + 6._r8)*d_rat + 6._r8) + + else + prci(i) = 0._r8 + nprci(i) = 0._r8 + end if + enddo +end subroutine ice_autoconversion + +! immersion freezing (Bigg, 1953) +!=================================== + +subroutine immersion_freezing(microp_uniform, t, pgam, lamc, & + qcic, ncic, relvar, mnuccc, nnuccc, mgncol) + + integer, intent(in) :: mgncol + logical, intent(in) :: microp_uniform + + ! Temperature + real(r8), dimension(mgncol), intent(in) :: t + + ! Cloud droplet size distribution parameters + real(r8), dimension(mgncol), intent(in) :: pgam + real(r8), dimension(mgncol), intent(in) :: lamc + + ! MMR and number concentration of in-cloud liquid water + real(r8), dimension(mgncol), intent(in) :: qcic + real(r8), dimension(mgncol), intent(in) :: ncic + + ! Relative variance of cloud water + real(r8), dimension(mgncol), intent(in) :: relvar + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: mnuccc ! MMR + real(r8), dimension(mgncol), intent(out) :: nnuccc ! Number + + ! Coefficients that will be omitted for sub-columns + real(r8), dimension(mgncol) :: dum + integer :: i + + if (.not. microp_uniform) then +! dum(:) = var_coef(relvar, 2) + do i=1,mgncol + dum(i) = gamma(relvar(i)+2)/gamma(relvar(i))/ relvar(i)**2 ! h1g, 2016-12-09 + enddo + else + dum(:) = 1._r8 + end if + do i=1,mgncol + + if (qcic(i) >= qsmall .and. t(i) < 269.15_r8) then + + nnuccc(i) = & + pi/6._r8*ncic(i)*rising_factorial(pgam(i)+1._r8, 3)* & + bimm*(exp(aimm*(tmelt - t(i)))-1._r8)/lamc(i)**3 + + mnuccc(i) = dum(i) * nnuccc(i) * & + pi/6._r8*rhow* & + rising_factorial(pgam(i)+4._r8, 3)/lamc(i)**3 + + else + mnuccc(i) = 0._r8 + nnuccc(i) = 0._r8 + end if ! qcic > qsmall and t < 4 deg C + enddo + +end subroutine immersion_freezing + +! contact freezing (-40= qsmall .and. t(i) < 269.15_r8) then + + if (.not. microp_uniform) then + dum = var_coef(relvar(i), 4._r8/3._r8) + dum1 = var_coef(relvar(i), 1._r8/3._r8) + else + dum = 1._r8 + dum1 = 1._r8 + endif + + tcnt=(270.16_r8-t(i))**1.3_r8 + viscosity = 1.8e-5_r8*(t(i)/298.0_r8)**0.85_r8 ! Viscosity (kg/m/s) + mfp = 2.0_r8*viscosity/ & ! Mean free path (m) + (p(i)*sqrt( 8.0_r8*28.96e-3_r8/(pi*8.314409_r8*t(i)) )) + + ! Note that these two are vectors. + nslip = 1.0_r8+(mfp/rndst(i,:))*(1.257_r8+(0.4_r8*exp(-(1.1_r8*rndst(i,:)/mfp))))! Slip correction factor + + ndfaer = 1.381e-23_r8*t(i)*nslip/(6._r8*pi*viscosity*rndst(i,:)) ! aerosol diffusivity (m2/s) + + contact_factor = dot_product(ndfaer,nacon(i,:)*tcnt) * pi * & + ncic(i) * (pgam(i) + 1._r8) / lamc(i) + + mnucct(i) = dum * contact_factor * & + pi/3._r8*rhow*rising_factorial(pgam(i)+2._r8, 3)/lamc(i)**3 + + nnucct(i) = dum1 * 2._r8 * contact_factor + + else + + mnucct(i)=0._r8 + nnucct(i)=0._r8 + + end if ! qcic > qsmall and t < 4 deg C + end do + +end subroutine contact_freezing + +! snow self-aggregation from passarelli, 1978, used by reisner, 1998 +!=================================================================== +! this is hard-wired for bs = 0.4 for now +! ignore self-collection of cloud ice + +subroutine snow_self_aggregation(t, rho, asn, rhosn, qsic, nsic, nsagg, mgncol) + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + real(r8), dimension(mgncol), intent(in) :: rho ! Density + real(r8), dimension(mgncol), intent(in) :: asn ! fall speed parameter for snow + real(r8), intent(in) :: rhosn ! density of snow + + ! In-cloud snow + real(r8), dimension(mgncol), intent(in) :: qsic ! MMR + real(r8), dimension(mgncol), intent(in) :: nsic ! Number + + ! Output number tendency + real(r8), dimension(mgncol), intent(out) :: nsagg + + integer :: i + + do i=1,mgncol + if (qsic(i) >= qsmall .and. t(i) <= tmelt) then + nsagg(i) = -1108._r8*eii/(4._r8*720._r8*rhosn)*asn(i)*qsic(i)*nsic(i)*rho(i)*& + ((qsic(i)/nsic(i))*(1._r8/(rhosn*pi)))**((bs-1._r8)/3._r8) + else + nsagg(i)=0._r8 + end if + enddo +end subroutine snow_self_aggregation + +! accretion of cloud droplets onto snow/graupel +!=================================================================== +! here use continuous collection equation with +! simple gravitational collection kernel +! ignore collisions between droplets/cloud ice +! since minimum size ice particle for accretion is 50 - 150 micron + +subroutine accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, qsic, & + pgam, lamc, lams, n0s, psacws, npsacws, use_const_ELI, ELI, mgncol) !h1g, 2020-04-16 + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + real(r8), dimension(mgncol), intent(in) :: rho ! Density + real(r8), dimension(mgncol), intent(in) :: asn ! Fallspeed parameter (snow) + real(r8), dimension(mgncol), intent(in) :: uns ! Current fallspeed (snow) + real(r8), dimension(mgncol), intent(in) :: mu ! Viscosity + + ! In-cloud liquid water + real(r8), dimension(mgncol), intent(in) :: qcic ! MMR + real(r8), dimension(mgncol), intent(in) :: ncic ! Number + + ! In-cloud snow + real(r8), dimension(mgncol), intent(in) :: qsic ! MMR + + ! Cloud droplet size parameters + real(r8), dimension(mgncol), intent(in) :: pgam + real(r8), dimension(mgncol), intent(in) :: lamc + + ! Snow size parameters + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + +!--> h1g, 2020-04-16 + logical, intent(in) :: use_const_ELI + real(r8), intent(in) :: ELI +!<-- h1g, 2020-04-16 + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: psacws ! Mass mixing ratio + real(r8), dimension(mgncol), intent(out) :: npsacws ! Number concentration + + real(r8) :: dc0 ! Provisional mean droplet size + real(r8) :: dum + real(r8) :: eci ! collection efficiency for riming of snow by droplets + + ! Fraction of cloud droplets accreted per second + real(r8) :: accrete_rate + integer :: i + + ! ignore collision of snow with droplets above freezing + + do i=1,mgncol + if (qsic(i) >= qsmall .and. t(i) <= tmelt .and. qcic(i) >= qsmall) then + + ! put in size dependent collection efficiency + ! mean diameter of snow is area-weighted, since + ! accretion is function of crystal geometric area + ! collection efficiency is approximation based on stoke's law (Thompson et al. 2004) + + dc0 = (pgam(i)+1._r8)/lamc(i) + dum = dc0*dc0*uns(i)*rhow*lams(i)/(9._r8*mu(i)) + eci = dum*dum/((dum+0.4_r8)*(dum+0.4_r8)) + + eci = max(eci,0._r8) + eci = min(eci,1._r8) + +!--> h1g, 2020-04-16 + if ( use_const_ELI ) eci = ELI +!<-- h1g, 2020-04-16 + + + ! no impact of sub-grid distribution of qc since psacws + ! is linear in qc + accrete_rate = pi/4._r8*asn(i)*rho(i)*n0s(i)*eci*gamma_bs_plus3 / lams(i)**(bs+3._r8) + psacws(i) = accrete_rate*qcic(i) + npsacws(i) = accrete_rate*ncic(i) + else + psacws(i) = 0._r8 + npsacws(i) = 0._r8 + end if + enddo +end subroutine accrete_cloud_water_snow + +! add secondary ice production due to accretion of droplets by snow +!=================================================================== +! (Hallet-Mossop process) (from Cotton et al., 1986) + +subroutine secondary_ice_production(t, psacws, msacwi, nsacwi, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + + ! Accretion of cloud water to snow tendencies + real(r8), dimension(mgncol), intent(inout) :: psacws ! MMR + + ! Output (ice) tendencies + real(r8), dimension(mgncol), intent(out) :: msacwi ! MMR + real(r8), dimension(mgncol), intent(out) :: nsacwi ! Number + integer :: i + + do i=1,mgncol + if((t(i) < 270.16_r8) .and. (t(i) >= 268.16_r8)) then + nsacwi(i) = 3.5e8_r8*(270.16_r8-t(i))/2.0_r8*psacws(i) + else if((t(i) < 268.16_r8) .and. (t(i) >= 265.16_r8)) then + nsacwi(i) = 3.5e8_r8*(t(i)-265.16_r8)/3.0_r8*psacws(i) + else + nsacwi(i) = 0.0_r8 + endif + enddo + + do i=1,mgncol + msacwi(i) = min(nsacwi(i)*mi0, psacws(i)) + psacws(i) = psacws(i) - msacwi(i) + enddo +end subroutine secondary_ice_production + +! accretion of rain water by snow +!=================================================================== +! formula from ikawa and saito, 1991, used by reisner et al., 1998 + +subroutine accrete_rain_snow(t, rho, umr, ums, unr, uns, qric, qsic, & + lamr, n0r, lams, n0s, pracs, npracs, mgncol) + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + real(r8), dimension(mgncol), intent(in) :: rho ! Density + + ! Fallspeeds + ! mass-weighted + real(r8), dimension(mgncol), intent(in) :: umr ! rain + real(r8), dimension(mgncol), intent(in) :: ums ! snow + ! number-weighted + real(r8), dimension(mgncol), intent(in) :: unr ! rain + real(r8), dimension(mgncol), intent(in) :: uns ! snow + + ! In cloud MMRs + real(r8), dimension(mgncol), intent(in) :: qric ! rain + real(r8), dimension(mgncol), intent(in) :: qsic ! snow + + ! Size distribution parameters + ! rain + real(r8), dimension(mgncol), intent(in) :: lamr + real(r8), dimension(mgncol), intent(in) :: n0r + ! snow + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: pracs ! MMR + real(r8), dimension(mgncol), intent(out) :: npracs ! Number + + ! Collection efficiency for accretion of rain by snow + real(r8), parameter :: ecr = 1.0_r8 + + ! Ratio of average snow diameter to average rain diameter. + real(r8) :: d_rat + ! Common factor between mass and number expressions + real(r8) :: common_factor + integer :: i + + do i=1,mgncol + if (qric(i) >= icsmall .and. qsic(i) >= icsmall .and. t(i) <= tmelt) then + + common_factor = pi*ecr*rho(i)*n0r(i)*n0s(i)/(lamr(i)**3 * lams(i)) + + d_rat = lamr(i)/lams(i) + + pracs(i) = common_factor*pi*rhow* & + sqrt((1.2_r8*umr(i)-0.95_r8*ums(i))**2 + 0.08_r8*ums(i)*umr(i)) / lamr(i)**3 * & + ((0.5_r8*d_rat + 2._r8)*d_rat + 5._r8) + + npracs(i) = common_factor*0.5_r8* & + sqrt(1.7_r8*(unr(i)-uns(i))**2 + 0.3_r8*unr(i)*uns(i)) * & + ((d_rat + 1._r8)*d_rat + 1._r8) + + else + pracs(i) = 0._r8 + npracs(i) = 0._r8 + end if + enddo +end subroutine accrete_rain_snow + +! heterogeneous freezing of rain drops +!=================================================================== +! follows from Bigg (1953) + +subroutine heterogeneous_rain_freezing(t, qric, nric, lamr, mnuccr, nnuccr, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + + ! In-cloud rain + real(r8), dimension(mgncol), intent(in) :: qric ! MMR + real(r8), dimension(mgncol), intent(in) :: nric ! Number + real(r8), dimension(mgncol), intent(in) :: lamr ! size parameter + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: mnuccr ! MMR + real(r8), dimension(mgncol), intent(out) :: nnuccr ! Number + integer :: i + + do i=1,mgncol + + if (t(i) < 269.15_r8 .and. qric(i) >= qsmall) then + nnuccr(i) = pi*nric(i)*bimm* & + (exp(aimm*(tmelt - t(i)))-1._r8)/lamr(i)**3 + + mnuccr(i) = nnuccr(i) * 20._r8*pi*rhow/lamr(i)**3 + + else + mnuccr(i) = 0._r8 + nnuccr(i) = 0._r8 + end if + enddo +end subroutine heterogeneous_rain_freezing + +! accretion of cloud liquid water by rain +!=================================================================== +! formula from Khrouditnov and Kogan (2000) +! gravitational collection kernel, droplet fall speed neglected + +subroutine accrete_cloud_water_rain(microp_uniform, qric, qcic, & + ncic, relvar, pra, npra, mgncol) + + logical, intent(in) :: microp_uniform + integer, intent(in) :: mgncol + ! In-cloud rain + real(r8), dimension(mgncol), intent(in) :: qric ! MMR + + ! Cloud droplets + real(r8), dimension(mgncol), intent(in) :: qcic ! MMR + real(r8), dimension(mgncol), intent(in) :: ncic ! Number + + ! SGS variability + real(r8), dimension(mgncol), intent(in) :: relvar +! real(r8), dimension(mgncol), intent(in) :: accre_enhan + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: pra ! MMR + real(r8), dimension(mgncol), intent(out) :: npra ! Number + + ! Coefficient that varies for subcolumns + real(r8), dimension(mgncol) :: pra_coef + + integer :: i + + if (.not. microp_uniform) then + do i=1, mgncol + pra_coef(i) = gamma(relvar(i)+1.15_r8)/gamma(relvar(i))/ relvar(i)**1.15 ! h1g, 2016-12-09 + enddo + else + pra_coef(:) = 1._r8 + end if + + do i=1,mgncol + + if (qric(i) >= qsmall .and. qcic(i) >= qsmall) then + + ! include sub-grid distribution of cloud water + pra(i) = pra_coef(i) * 67._r8*(qcic(i)*qric(i))**1.15_r8 + + npra(i) = pra(i)*ncic(i)/qcic(i) + + else + pra(i) = 0._r8 + npra(i) = 0._r8 + end if + end do +end subroutine accrete_cloud_water_rain + +! Self-collection of rain drops +!=================================================================== +! from Beheng(1994) + +subroutine self_collection_rain(rho, qric, nric, nragg, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: rho ! Air density + + ! Rain + real(r8), dimension(mgncol), intent(in) :: qric ! MMR + real(r8), dimension(mgncol), intent(in) :: nric ! Number + + ! Output number tendency + real(r8), dimension(mgncol), intent(out) :: nragg + + integer :: i + + do i=1,mgncol + if (qric(i) >= qsmall) then + nragg(i) = -8._r8*nric(i)*qric(i)*rho(i) + else + nragg(i) = 0._r8 + end if + enddo +end subroutine self_collection_rain + + +! Accretion of cloud ice by snow +!=================================================================== +! For this calculation, it is assumed that the Vs >> Vi +! and Ds >> Di for continuous collection + +subroutine accrete_cloud_ice_snow(t, rho, asn, qiic, niic, qsic, & + lams, n0s, prai, nprai, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + real(r8), dimension(mgncol), intent(in) :: rho ! Density + + real(r8), dimension(mgncol), intent(in) :: asn ! Snow fallspeed parameter + + ! Cloud ice + real(r8), dimension(mgncol), intent(in) :: qiic ! MMR + real(r8), dimension(mgncol), intent(in) :: niic ! Number + + real(r8), dimension(mgncol), intent(in) :: qsic ! Snow MMR + + ! Snow size parameters + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: prai ! MMR + real(r8), dimension(mgncol), intent(out) :: nprai ! Number + + ! Fraction of cloud ice particles accreted per second + real(r8) :: accrete_rate + + integer :: i + + do i=1,mgncol + if (qsic(i) >= qsmall .and. qiic(i) >= qsmall .and. t(i) <= tmelt) then + + accrete_rate = pi/4._r8 * eii * asn(i) * rho(i) * n0s(i) * gamma_bs_plus3/ & + lams(i)**(bs+3._r8) + + prai(i) = accrete_rate * qiic(i) + nprai(i) = accrete_rate * niic(i) + + else + prai(i) = 0._r8 + nprai(i) = 0._r8 + end if + enddo +end subroutine accrete_cloud_ice_snow + +! calculate evaporation/sublimation of rain and snow +!=================================================================== +! note: evaporation/sublimation occurs only in cloud-free portion of grid cell +! in-cloud condensation/deposition of rain and snow is neglected +! except for transfer of cloud water to snow through bergeron process + +subroutine evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, & + lcldm, precip_frac, arn, asn, qcic, qiic, qric, qsic, lamr, n0r, lams, n0s, & + pre, prds, am_evp_st, mgncol) + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent(in) :: t ! temperature + real(r8), dimension(mgncol), intent(in) :: rho ! air density + real(r8), dimension(mgncol), intent(in) :: dv ! water vapor diffusivity + real(r8), dimension(mgncol), intent(in) :: mu ! viscosity + real(r8), dimension(mgncol), intent(in) :: sc ! schmidt number + real(r8), dimension(mgncol), intent(in) :: q ! humidity + real(r8), dimension(mgncol), intent(in) :: qvl ! saturation humidity (water) + real(r8), dimension(mgncol), intent(in) :: qvi ! saturation humidity (ice) + real(r8), dimension(mgncol), intent(in) :: lcldm ! liquid cloud fraction + real(r8), dimension(mgncol), intent(in) :: precip_frac ! precipitation fraction (maximum overlap) + + ! fallspeed parameters + real(r8), dimension(mgncol), intent(in) :: arn ! rain + real(r8), dimension(mgncol), intent(in) :: asn ! snow + + ! In-cloud MMRs + real(r8), dimension(mgncol), intent(in) :: qcic ! cloud liquid + real(r8), dimension(mgncol), intent(in) :: qiic ! cloud ice + real(r8), dimension(mgncol), intent(in) :: qric ! rain + real(r8), dimension(mgncol), intent(in) :: qsic ! snow + + ! Size parameters + ! rain + real(r8), dimension(mgncol), intent(in) :: lamr + real(r8), dimension(mgncol), intent(in) :: n0r + ! snow + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: pre + real(r8), dimension(mgncol), intent(out) :: prds + real(r8), dimension(mgncol), intent(out) :: am_evp_st ! Fractional area where rain evaporates. + + real(r8) :: qclr ! water vapor mixing ratio in clear air + real(r8) :: ab ! correction to account for latent heat + real(r8) :: eps ! 1/ sat relaxation timescale + + real(r8), dimension(mgncol) :: dum + + integer :: i + + am_evp_st = 0._r8 + ! set temporary cloud fraction to zero if cloud water + ice is very small + ! this will ensure that evaporation/sublimation of precip occurs over + ! entire grid cell, since min cloud fraction is specified otherwise + do i=1,mgncol + if (qcic(i)+qiic(i) < 1.e-6_r8) then + dum(i) = 0._r8 + else + dum(i) = lcldm(i) + end if + enddo + do i=1,mgncol + ! only calculate if there is some precip fraction > cloud fraction + + if (precip_frac(i) > dum(i)) then + + if (qric(i) >= qsmall .or. qsic(i) >= qsmall) then + am_evp_st(i) = precip_frac(i) - dum(i) + + ! calculate q for out-of-cloud region + qclr=(q(i)-dum(i)*qvl(i))/(1._r8-dum(i)) + end if + + ! evaporation of rain + if (qric(i) >= qsmall) then + + ab = calc_ab(t(i), qvl(i), xxlv) + eps = 2._r8*pi*n0r(i)*rho(i)*Dv(i)* & + (f1r/(lamr(i)*lamr(i))+ & + f2r*(arn(i)*rho(i)/mu(i))**0.5_r8* & + sc(i)**(1._r8/3._r8)*gamma_half_br_plus5/ & + (lamr(i)**(5._r8/2._r8+br/2._r8))) + + pre(i) = eps*(qclr-qvl(i))/ab + + ! only evaporate in out-of-cloud region + ! and distribute across precip_frac + pre(i)=min(pre(i)*am_evp_st(i),0._r8) + pre(i)=pre(i)/precip_frac(i) + else + pre(i) = 0._r8 + end if + + ! sublimation of snow + if (qsic(i) >= qsmall) then + ab = calc_ab(t(i), qvi(i), xxls) + eps = 2._r8*pi*n0s(i)*rho(i)*Dv(i)* & + (f1s/(lams(i)*lams(i))+ & + f2s*(asn(i)*rho(i)/mu(i))**0.5_r8* & + sc(i)**(1._r8/3._r8)*gamma_half_bs_plus5/ & + (lams(i)**(5._r8/2._r8+bs/2._r8))) + prds(i) = eps*(qclr-qvi(i))/ab + + ! only sublimate in out-of-cloud region and distribute over precip_frac + prds(i)=min(prds(i)*am_evp_st(i),0._r8) + prds(i)=prds(i)/precip_frac(i) + else + prds(i) = 0._r8 + end if + + else + prds(i) = 0._r8 + pre(i) = 0._r8 + end if + enddo + +end subroutine evaporate_sublimate_precip + +! bergeron process - evaporation of droplets and deposition onto snow +!=================================================================== + +subroutine bergeron_process_snow(t, rho, dv, mu, sc, qvl, qvi, asn, & + qcic, qsic, lams, n0s, bergs, mgncol) + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent(in) :: t ! temperature + real(r8), dimension(mgncol), intent(in) :: rho ! air density + real(r8), dimension(mgncol), intent(in) :: dv ! water vapor diffusivity + real(r8), dimension(mgncol), intent(in) :: mu ! viscosity + real(r8), dimension(mgncol), intent(in) :: sc ! schmidt number + real(r8), dimension(mgncol), intent(in) :: qvl ! saturation humidity (water) + real(r8), dimension(mgncol), intent(in) :: qvi ! saturation humidity (ice) + + ! fallspeed parameter for snow + real(r8), dimension(mgncol), intent(in) :: asn + + ! In-cloud MMRs + real(r8), dimension(mgncol), intent(in) :: qcic ! cloud liquid + real(r8), dimension(mgncol), intent(in) :: qsic ! snow + + ! Size parameters for snow + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: bergs + + real(r8) :: ab ! correction to account for latent heat + real(r8) :: eps ! 1/ sat relaxation timescale + + integer :: i + + do i=1,mgncol + ! if (qsic(i) >= qsmall.and. qcic(i) >= qsmall .and. t(i) < tmelt) then ! h1g 2020-04-01 + if (qsic(i)>= qsmall .and. t(i)tmelt-40.0 ) then ! h1g 2020-06-25 + ab = calc_ab(t(i), qvi(i), xxls) + eps = 2._r8*pi*n0s(i)*rho(i)*Dv(i)* & + (f1s/(lams(i)*lams(i))+ & + f2s*(asn(i)*rho(i)/mu(i))**0.5_r8* & + sc(i)**(1._r8/3._r8)*gamma_half_bs_plus5/ & + (lams(i)**(5._r8/2._r8+bs/2._r8))) + bergs(i) = eps*(qvl(i)-qvi(i))/ab + else + bergs(i) = 0._r8 + end if + enddo +end subroutine bergeron_process_snow + +!======================================================================== +!UTILITIES +!======================================================================== + +pure function no_limiter() + real(r8) :: no_limiter + + no_limiter = transfer(limiter_off, no_limiter) + +end function no_limiter + +pure function limiter_is_on(lim) + real(r8), intent(in) :: lim + logical :: limiter_is_on + + limiter_is_on = transfer(lim, limiter_off) /= limiter_off + +end function limiter_is_on + +end module micro_mg2_utils diff --git a/atmos_param/moist_processes/moist_processes.F90 b/atmos_param/moist_processes/moist_processes.F90 index df9320d3..9f9c2287 100644 --- a/atmos_param/moist_processes/moist_processes.F90 +++ b/atmos_param/moist_processes/moist_processes.F90 @@ -682,7 +682,7 @@ subroutine moist_processes ( is, ie, js, je, npz, Time, land, ustar, & Moist_clouds_block, Input_mp, Tend_mp, C2ls_mp, & Output_mp, Removal_mp, Aerosol=Aerosol) call lscloud_driver & - (is, ie, js, je, Time, dt, Input_mp, & + (is, ie, js, je, Time, dt, lon, lat, Input_mp, & Physics_tendency_block%qdiag, Tend_mp, C2ls_mp, & Output_mp, Removal_mp, & Moist_clouds_block%cloud_data(istrat), & @@ -1473,11 +1473,22 @@ subroutine combined_MP_diagnostics & !--------------------------------------------------------------------- ! define the total and convective ice and ice water path. !--------------------------------------------------------------------- +!--> h1g, 2020-01-07, "ice_amt" in RK microphysics includes both ice and snow. +! "ice_amt" in MG, MG1.5, and MG2 only include ice. +!in order to compare orange with orange, I added large-scale snow in "ice_amt". + +! if (id_tot_ice_amt > 0 ) & +! used = send_data (id_tot_ice_amt, & +! (Moist_clouds_block%cloud_data(i_lsc)%ice_amt + tot_conv_ice)/ & +! (1.0 + total_conv_cloud), & +! Time, is, js, 1) + if (id_tot_ice_amt > 0 ) & used = send_data (id_tot_ice_amt, & - (Moist_clouds_block%cloud_data(i_lsc)%ice_amt + tot_conv_ice)/ & + (Moist_clouds_block%cloud_data(i_lsc)%ice_amt + tot_conv_ice+Moist_clouds_block%cloud_data(i_lsc)%snow)/ & (1.0 + total_conv_cloud), & Time, is, js, 1) +!<-- h1g, 2020-01-07 if (query_cmip_diag_id(ID_cli)) then used = send_cmip_data_3d (ID_cli, & diff --git a/atmos_param/physics_driver/physics_driver.F90 b/atmos_param/physics_driver/physics_driver.F90 index 13d710db..baa6f948 100644 --- a/atmos_param/physics_driver/physics_driver.F90 +++ b/atmos_param/physics_driver/physics_driver.F90 @@ -799,6 +799,10 @@ subroutine physics_driver_init (Time, lonb, latb, lon, lat, axes, & Physics%control%nqr = get_tracer_index (MODEL_ATMOS, 'rainwat') Physics%control%nqs = get_tracer_index (MODEL_ATMOS, 'snowwat') Physics%control%nqg = get_tracer_index (MODEL_ATMOS, 'graupel') + + Physics%control%nqnr = get_tracer_index (MODEL_ATMOS, 'rain_num') + Physics%control%nqns = get_tracer_index (MODEL_ATMOS, 'snow_num') + physics_domain = Physics%control%domain !----------------------------------------------------------------------- ! allocate a logical array to define whether a tracer is a cloud tracer @@ -836,6 +840,13 @@ subroutine physics_driver_init (Time, lonb, latb, lon, lat, axes, & Physics%control%cloud_tracer(Physics%control%nqg ) = .TRUE. endif + if (Physics%control%nqnr /= NO_TRACER) then + Physics%control%cloud_tracer(Physics%control%nqnr ) = .TRUE. + endif + if (Physics%control%nqns /= NO_TRACER) then + Physics%control%cloud_tracer(Physics%control%nqns ) = .TRUE. + endif + !---------------------------------------------------------------------- ! define logical variable indicating whether prognostic clouds (using ! tracer fields) are active. diff --git a/atmos_param/physics_driver/physics_types.F90 b/atmos_param/physics_driver/physics_types.F90 index ecb75b91..b4283037 100644 --- a/atmos_param/physics_driver/physics_types.F90 +++ b/atmos_param/physics_driver/physics_types.F90 @@ -12,6 +12,7 @@ module physics_types_mod type physics_control_type integer :: sphum integer :: nsphum, nql, nqi, nqa, nqn, nqni, nqr, nqs, nqg + integer :: nqnr, nqns integer :: num_prog_tracers logical :: hydrostatic, phys_hydrostatic, do_uni_zfull !miz logical :: l_host_applies_sfc_fluxes diff --git a/atmos_shared/tracer_driver/aer_ccn_act/ice_nucl.F90 b/atmos_shared/tracer_driver/aer_ccn_act/ice_nucl.F90 index 88ce7e76..f5f7348c 100644 --- a/atmos_shared/tracer_driver/aer_ccn_act/ice_nucl.F90 +++ b/atmos_shared/tracer_driver/aer_ccn_act/ice_nucl.F90 @@ -25,6 +25,7 @@ MODULE ice_nucl_mod !--interfaces------------------------------------------------------------- public ice_nucl_wpdf, ice_nucl_wpdf_init, ice_nucl_wpdf_end +public ice_nucl_wpdf_Fan ! Gaussian integration over Fan'shomogeneous nucleation h1g, 2020-05-17 private ice_nucl_k, fast, slow, bc_het !------------------------------------------------------------------------ @@ -74,6 +75,8 @@ MODULE ice_nucl_mod ! d_bc = 0.07e-6 !Pueschel et al., GRL,1992 ! d_bc = 0.04e-6 +real :: nbc_max = 100.0 ! maximum BC particle number concentration (/cm3) h1g, 2020-07-03 + real :: rh_crit_het = 1.2 ! real :: dust_surf = 0.5 ! real :: dust_frac_min = 0.0 ! @@ -83,13 +86,20 @@ MODULE ice_nucl_mod !RSH: Should this be 150. or 1.5 (150 %) ???? real :: rh_dust_max = 150. ! maximum ice supersaturation in the ! presence of dust +! h1g, 2020-02-20 +real :: Nimax = 1.e8 ! maximum nucleated ice number concentration (#/m3) +! h1g, 2020-05-24 +real :: Nimax_heteo = 40.0e3 ! Songmiao Fan's maximum heterogeneous nucleated ice number concentration (#/m3) +real :: Nice_het_fac = 1.0 namelist / ice_nucl_nml / dust_opt, do_het, use_dust_instead_of_bc, & limit_immersion_frz, limit_rhil, & do_ice_nucl_ss_wpdf, d_sulf, & d_bc, rh_crit_het, dust_surf, dust_frac_min, & - dust_frac_max, dust_frac, rh_dust_max, retain_ice_nucl_bug + dust_frac_max, dust_frac, rh_dust_max, retain_ice_nucl_bug, & + Nimax, Nimax_heteo, Nice_het_fac, nbc_max ! h1g, 2020-05-24 + integer, parameter :: npoints = 64 ! # for Gauss-Hermite quadrature real, parameter :: wp2_eps = 0.0001 ! w variance threshold @@ -378,7 +388,7 @@ SUBROUTINE ice_nucl_k (zfull, T1, rhi_in, rhl_in, W1, TotalMass, & ! black carbon is activated. 1.e-6 is conversion from from m^-3 to cm^-3. !------------------------------------------------------------------------- nbc = MIN(imass(6)*1.e-6*6./(rho_bc*pi*d_bc**3)* & - exp(-9./2. * (log(sigma_bc))**2), 1.e10) + exp(-9./2. * (log(sigma_bc))**2), nbc_max) ENDIF !------------------------------------------------------------------------- @@ -420,7 +430,7 @@ SUBROUTINE ice_nucl_k (zfull, T1, rhi_in, rhl_in, W1, TotalMass, & !------------------------------------------------------------------------- else do_hom = .TRUE. - endif + endif ! nbc .GT. nbccrit !------------------------------------------------------------------------- ! if insufficient humidty for heterogenous nucleation, @@ -428,7 +438,7 @@ SUBROUTINE ice_nucl_k (zfull, T1, rhi_in, rhl_in, W1, TotalMass, & !------------------------------------------------------------------------- else do_hom = .TRUE. - endif + endif !1.e2*rhl .GE. rhl_thresh !------------------------------------------------------------------------- ! if heterogeneous nucleation was not requested, or the vertical velocity @@ -437,7 +447,7 @@ SUBROUTINE ice_nucl_k (zfull, T1, rhi_in, rhl_in, W1, TotalMass, & !------------------------------------------------------------------------- else do_hom = .TRUE. - endif + endif ! do_het .and. w1 .GE. w_het_thresh !------------------------------------------------------------------------- ! calculate homogeneous nucleation. @@ -516,8 +526,8 @@ SUBROUTINE ice_nucl_k (zfull, T1, rhi_in, rhl_in, W1, TotalMass, & ! convert the activated number to m-3. !------------------------------------------------------------------------ Ni_sulf = MAX(1.e6 * Ni_sulf, 0.) - END IF - END IF + END IF ! 1.e2*rhl .GE. rhl_thresh + END IF ! do_hom .and. w1 .GE. w_hom_thresh !------------------------------------------------------------------------- ! calculate activated ice nuclei when temperature is between -5C and @@ -633,7 +643,8 @@ SUBROUTINE ice_nucl_k (zfull, T1, rhi_in, rhl_in, W1, TotalMass, & ! sum the total available ice nulei. limit the number to be between 0 ! and 1.0e8. !------------------------------------------------------------------------- - Ni = MIN( MAX(Ni_sulf + Ni_dust + Ni_bc, 0.), 1.e8) + + Ni = MIN( MAX(Ni_sulf + Ni_dust + Ni_bc, 0.), Nimax) !------------------------------------------------------------------------- ! define output variable hom to be 1 when homogeneous nucleation has @@ -772,4 +783,160 @@ END SUBROUTINE S_max !------------------------------------------------------------------------ +SUBROUTINE ice_nucl_wpdf_Fan (T, p, wm, wp2, concen_dust_sub, crystal, Nidust) +! --------------------------------------------------------------------- +! subroutine ice_nucl_wpdf computes ice nucleation assuming a normal +! distribution of w given by its mean (wm) and second moment (wp2) +!------------------------------------------------------------------------ +real, intent(in) :: P, T, wm, wp2, concen_dust_sub +real, intent(out) :: crystal ! homegeneously nucleated ice number (#/m3) +real, intent(out) :: Nidust ! heteorogeously nucleated ice number (#/m3) + + +!-------------------------------------------------------------------------- +!---local variables + + logical lintegrate + integer ia, ib + real wtmp + real(kind=8) :: tmp, a, b, sum1, sum2 + integer iw + +!------------------------------------------------------------------------- +! determine whether integration is needed to compute number of nucleated +! crystals. lintegrate = .true. indicates that numerical integration is +! to be performed. +!------------------------------------------------------------------------- + if (wp2 .gt. wp2_eps) then + +!------------------------------------------------------------------------- +! integration bounds: from wmin to wmax (0 to 10 m/s) +!------------------------------------------------------------------------- + tmp = 1.0d0/sqrt(2.0*wp2) + a = (wmin - wm)*tmp + b = (wmax - wm)*tmp + +!------------------------------------------------------------------------- +! locate indices within integration bounds +!------------------------------------------------------------------------- + call dlocate( x, npoints, a, ia ) + call dlocate( x, npoints, b, ib ) + +!------------------------------------------------------------------------- +! ia (ib) is zero if a (b) is smaller than the lowest abscissa. +! in that case, start the integration with the first abscissa. +!------------------------------------------------------------------------- + ia = ia +1 + ia = min(max(ia,1),size(x)) + ib = min(max(ib,1),size(x)) + if (ib .gt. ia) then + lintegrate = .true. + else + lintegrate = .false. + endif + else + lintegrate = .false. + endif + +!------------------------------------------------------------------------- +! compute number of nucleated crystals. +!------------------------------------------------------------------------- + if (lintegrate ) then + sum1 = 0.0d0 + sum2 = 0.0d0 + tmp = sqrt(2.0*wp2) + do iw=ia,ib + wtmp = tmp * x(iw) + wm + call Nice_cirrus ( T, P, wtmp, concen_dust_sub, crystal) + sum1 = sum1 + w(iw)*crystal + sum2 = sum2 + w(iw) + enddo + +!------------------------------------------------------------------------- +! normalize over the distribution. +!------------------------------------------------------------------------- + crystal = sum1 / sum2 + else + ! otherwise no need to integrate, use single point (wm) + call Nice_cirrus ( T, P, wm, concen_dust_sub, crystal) + endif + +! heteogeneous nucleation + call Nice_sc_dust ( T, P, concen_dust_sub, Nidust) + +end subroutine ice_nucl_wpdf_Fan + + + +subroutine Nice_cirrus (temp, p, wmps, concen_dust, nice) + real, intent(in) :: temp, p, wmps, concen_dust ! Pa, K, m/s, ug/m3 + real, intent(out) :: nice ! (#/m3) + + real fact ! active fraction + real dust, delt, wcmps, sech + real tmp0, tmp1, tmp2, tmp3, tmp4 + + + fact = 1.0 + nice = 0. + dust = concen_dust * fact + nice = 0.0 + wcmps = 100. * wmps + if (wcmps .lt. 0.01) return + tmp0 = log(wcmps) + tmp1 = 0. + tmp2 = 0. + tmp3 = 0. + tmp4 = 0. + + if (temp .gt. 180. .and. temp .le. 210.) then + delt = temp - 197. + sech = 2. / (exp(0.19 * delt) + exp(-0.19 * delt)) + tmp1 = wcmps * (0.075 + 0.0062 * tmp0) + tmp2 = dust**0.3 * sech * tmp1 + nice = min(tmp2, 4.1 * dust) + else if (temp .gt. 210. .and. temp .le. 220.) then + delt = temp - 197. + sech = 2. / (exp(0.19 * delt) + exp(-0.19 * delt)) + tmp1 = wcmps * (0.075 + 0.0062 * tmp0) + tmp2 = dust**0.3 * sech * tmp1 + + delt = temp - 227. + tmp3 = -5.67+1.04*tmp0 & + + (0.0424 - 0.0626*tmp0 + 0.00865*tmp0*tmp0)*delt + tmp4 = dust**0.3 * exp(tmp3) + + nice = max(min(tmp2, 4.1 * dust), min(tmp4, 4.1 * dust)) + else if (temp .gt. 220. .and. temp .le. 240.) then + delt = temp - 227. + tmp3 = -5.67+1.04*tmp0 & + + (0.0424 - 0.0626*tmp0 + 0.00865*tmp0*tmp0)*delt + tmp4 = dust**0.3 * exp(tmp3) + nice = min(tmp4, 4.1 * dust) + else + nice = 0. +! print *, ' Temperature out of range 180 K to 240 K ' + end if + + nice = nice * 1.e6 ! convert from #/cm3 to #/m3 + + nice = nice * p / 30000.0 +end subroutine Nice_cirrus +!------------------------------------------------------------------------- + + +subroutine Nice_sc_dust (temp, p, concen_dust, nice) + real, intent(in) :: temp, p, concen_dust ! K, Pa, microg/m3 + real, intent(out) :: nice ! (#/m3) + + nice = Nice_het_fac * 0.00274 * concen_dust * & + exp(0.412*(273.16 - temp)) ! nice #/L + nice = nice * 1.e3 ! from /L to /m3 + nice = min(Nimax_heteo, nice) + + nice = nice * p/95000.0 +end subroutine Nice_sc_dust + + + END MODULE ice_nucl_mod